Hi Clive,
here is my module for dealing with properties:
Attribute VB_Name = "bas_Crystal_Properties_customized"
Option Compare Database
Option Explicit
'
'=======================================================
' bas_Crystal_Properties_customized
'=======================================================
'
' This code was orignally written by Crystal
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided this copyright notice is left unchanged.
'
' This module has been customized for Enercom
'
' Crystal
' strive4peace2010 at yahoo.com
' 081213 - cma
'
' NEEDS Reference to:
' Microsoft DAO Library
' OR
' Microsoft Office ##.0 Access Database Engine Object Library
'
' this is intended to be a generic module
' As written, however, custom procedures are called
' It is assumed that anybody using this module
' will have set properties that are defined
' and the custom procedures will be customized or
' the entire procedure(s) will be commented
'
' if custom procedures are commented in their entirety,
' when you Debug/Compile
' the compiler will tell you where they are <smile>
' then comment/modify those additional statements
'
'~~~
' CUSTOM
'- custom_SetDefaultProperties
'- custom_ReadFindProperties
'- custom_WriteFindProperties
'
'~~~
' GENERIC
'- Set_Property
'- Get_Property
'- Delete_Property
'- IsPropertyDefined
'
'~~~
'FYI
'- ShowPropValues
'- ShowPropValueForName
'
'~~~
'EXAMPLES
'- GetDefaultMainID
'- SetDefaultMainID
'- RunDeleteDatabaseProperty
'
'~~~
'for good measure ...
'- HideDBWindow
'- UnHideDBWindow
'=======================================================
'
'
'
'******************************************************
' CUSTOM routines
'******************************************************
' this is where you define the 'default' database properties
' this will need to be run each time you
' : create a copy of the database by importing objects
' (since database properties are not imported)
'
'~~~~~~~~~~~~~~~~~~~~~ custom_SetDefaultProperties
' CUSTOMIZE
'
Sub custom_SetDefaultProperties( _
Optional pCat As String = "" _
, Optional bSkipMsg As Boolean = True _
, Optional bSkipAlreadySet As Boolean = True _
, Optional pPropName As String = "" _
, Optional obj As Object _
)
'100829, 30 template
'comment this line if you have not customized this procedure
'exit sub
' PARAMETERS
' pCat = property category
' ie: db --> Overall database properties
' find --> properties for the FIND form
' if ZLS or not given,
' default --> execute all categories
' bSkipMsg = True: skip user intereraction
' bSkipAlreadySet = True: skip if property already set
' pPropName = set a specific property
' if pCat is not given, all categories will be searched
' obj = database, field, tabledef, querydef,
' or other object with properties
' if obj is not specified, then CurrentDb is used
'
' CALLS
' IsPropertyDefined if bSkipAlreadySet
' Set_Property
On Error GoTo Proc_Err
Dim i As Integer _
, mPropName As String _
, mPropType As Long _
, varValue As Variant
If obj Is Nothing Then
Set obj = CurrentDb
End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ DB properties
If pCat = "" Or pCat = "db" Then
For i = 1 To 9
Select Case i
Case 1
mPropName = "local_IsAdmin"
mPropType = dbBoolean
varValue = True
Case 2
mPropName = "local_UserID"
mPropType = dbLong
varValue = 0
Case 3
mPropName = "local_FileBE"
mPropType = dbText
varValue = "PeerMetrics_BE_100915.mdb"
'===============================================================
' update when template changes
'===============================================================
Case 4
mPropName = "local_FileRpt"
mPropType = dbText
varValue = "PeerMetrics_BE_Rpt.mdb"
Case 5
mPropName = "local_FileTemplate"
mPropType = dbText
varValue = "PeerMetrics_BE_RptTemplate_100830.mdb"
Case 6
mPropName = "local_PathRpt"
mPropType = dbText
varValue = " "
Case 7
mPropName = "local_PathBE"
mPropType = dbText
varValue = " "
Case 8
mPropName = "local_PathTemplate"
mPropType = dbText
varValue = " "
Case 9
mPropName = "local__BE_is_ok"
mPropType = dbBoolean
varValue = False
End Select
If bSkipAlreadySet Then
If IsPropertyDefined(mPropName, obj) Then
GoTo NextProp_Db
End If
End If
If mPropName = pPropName Then
Set_Property mPropName, varValue, mPropType, obj, bSkipMsg
GoTo Proc_Exit
ElseIf pPropName = "" Then
Set_Property mPropName, varValue, mPropType, obj, bSkipMsg
End If
NextProp_Db:
Next i
End If
If Not bSkipMsg Then
MsgBox "Default Database Properties are set", , "Done"
End If
Proc_Exit:
Exit Sub
Proc_Err:
MsgBox Err.Description, , _
"ERROR " & Err.Number _
& " custom_SetDefaultProperties"
Resume Proc_Exit
'if you want to single-step code to find error, CTRL-Break at MsgBox
'then set this to be the next statement
Resume
End Sub
Function ToggleProperCase(Optional pBoo As Integer = -99) As Boolean
Dim mBoo As Boolean
If pBoo = -99 Then
mBoo = Get_Property("DefaultProperCase")
mBoo = Not mBoo
Else
mBoo = pBoo
End If
Set_Property "DefaultProperCase", mBoo, dbBoolean
ToggleProperCase = mBoo
End Function
'******************************************************
' Generic Procedures
'******************************************************
'~~~~~~~~~~~~~~~~~~~~~ Set_Property
Public Function Set_Property( _
pPropName As String _
, Optional pValue As Variant _
, Optional pDataType As Long = 0 _
, Optional obj As Object _
, Optional bSkipMsg As Boolean = True _
) As Byte
' Crystal
' strive4peace2008 at yahoo.com
' 8-9
' PARAMETERS
' pPropName is the (database) property name to set
' optional:
' pValue is the value for the property
' pDataType is the Data Type: dbBoolean, dbLong, dbText, ...
' if not passed -- uses defaults
' bSkipMsg = True: don't give user feedback
' obj = database, field, tabledef, querydef,
' or other object with properties
' if obj is not specified, then CurrentDb is used
'
' CALLS
' IsPropertyDefined
' CALLS CUSTOM CODE
' custom_SetDefaultProperties
' -- if this is not applicable, change code
'set up Error Handler
On Error GoTo Proc_Err
If obj Is Nothing Then
Set obj = CurrentDb
End If
If IsPropertyDefined(pPropName, obj) Then
'Property already exists
If IsMissing(pValue) Then
'set value to default
custom_SetDefaultProperties , , False, pPropName, obj
Else
obj.Properties(pPropName) = pValue
End If
Else
'Property does not exist
If pDataType = 0 Then
'data type not passed, use defaults
'NOTE: no error checking is done here
custom_SetDefaultProperties , , False, pPropName, obj
Else
If IsMissing(pValue) Then
'set value to default
custom_SetDefaultProperties , , False, pPropName, obj
Else
obj.Properties.Append _
obj.CreateProperty( _
pPropName, pDataType, pValue)
End If
End If
End If
If Not bSkipMsg Then
MsgBox pPropName & " is --> " _
& obj.Properties(pPropName) _
& vbCrLf & " for: " _
& obj.Name, , "Done setting property"
End If
Proc_Exit:
Exit Function
Proc_Err:
MsgBox Err.Description, , _
"ERROR " & Err.Number _
& " Set_Property"
' Resume Proc_Exit
Stop: Resume
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'
' this is a generic public function to be used to
' get the value of a database property
' you can pass an optional database object
' if you want to look somewhere other than CurrentDb
'~~~~~~~~~~~~~~~~~~~~~ Get_Property
Public Function Get_Property( _
pPropName As String _
, Optional obj As Object _
) As Variant
'Crystal
' strive4peace2008 at yahoo.com
' 8-9
' PARAMETERS
' pPropName is the (database) property name to return the value of
' optional:
' obj = database, field, tabledef, querydef,
' or other object with properties
' if obj is not specified, then CurrentDb is used
'
' CALLS
' IsPropertyDefined
' Set_Property
'RETURNS
' Null if property has no value or is not defined
' OR
' Value of property
' Assumes all needed properties are defined
On Error GoTo Proc_Err
Get_Property = Null
Get_Property = Null
On Error GoTo Proc_Exit
If obj Is Nothing Then
Set obj = CurrentDb
End If
If Not IsPropertyDefined(pPropName, obj) Then
'if property is not defined
'set a custom value -- called by Set_Property
If Set_Property(pPropName) Then
Get_Property = obj.Properties(pPropName)
GoTo Proc_Exit
Else
'value could not be set and,
' therefore, not retrieved
GoTo Proc_Exit
End If
Else
Get_Property = obj.Properties(pPropName)
End If
Proc_Exit:
Exit Function
Proc_Err:
MsgBox Err.Description, , _
"ERROR " & Err.Number _
& " Get_Property"
Resume Proc_Exit
Resume
End Function
'
'
' this is a generic public function to delete a database property
'~~~~~~~~~~~~~~~~~~~~~ Delete_Property
Public Function Delete_Property( _
ByVal pPropName As String _
, Optional bSkipMsg As Boolean = False _
, Optional obj As Object _
) As Boolean
'Crystal
' strive4peace2008 at yahoo.com
' 8-9
' PARAMETERS
' pPropName is the (database) property name to return the value of
' optional:
' obj = database, field, tabledef, querydef,
' or other object with properties
' if obj is not specified, then CurrentDb is used
'
' CALLS
' IsPropertyDefined
'ignore errors -- it may not be set
On Error GoTo Proc_Err
Delete_Property = False
If obj Is Nothing Then
Set obj = CurrentDb
End If
If IsPropertyDefined(pPropName, obj) Then
obj.Properties.Delete pPropName
End If
If Not bSkipMsg Then
MsgBox pPropName & " is deleted", , "Done"
End If
Delete_Property = True
Proc_Exit:
Exit Function
Proc_Err:
MsgBox Err.Description, , _
"ERROR " & Err.Number _
& " Delete_Property"
Resume Proc_Exit
Resume
End Function
'
' see if a property is defined
'
'~~~~~~~~~~~~~~~~~~~~~ IsPropertyDefined
Public Function IsPropertyDefined( _
ByVal pPropName As String _
, Optional obj As Object _
) As Boolean
'Crystal (strive4peace2008 at yahoo.com)
'
'PARAMETERS
' Obj can be a database, a Tabledef, a Field...
' if it is missing, CurrentDb is used
'
On Error GoTo Proc_Err
IsPropertyDefined = False
Dim prp As DAO.Property
If obj Is Nothing Then
Set obj = CurrentDb
End If
For Each prp In obj.Properties
If prp.Name = pPropName Then
IsPropertyDefined = True
GoTo Proc_Exit
End If
Next prp
Proc_Exit:
Set prp = Nothing
Exit Function
Proc_Err:
MsgBox Err.Description, , _
"ERROR " & Err.Number _
& " IsPropertyDefined"
Resume Proc_Exit
'if you want to single-step code to find error, CTRL-Break at MsgBox
'then set this to be the next statement
Resume
End Function
'******************************************************
' FYI
'******************************************************
' not needed -- included FYI
'
'
'~~~~~~~~~~~~~~~~~~~~~ ShowPropValues
' loop through (database) properties
' show name and value in Debug window
'
Public Sub ShowPropValues( _
Optional obj As Object _
, Optional bCustom As Boolean = True _
)
'Crystal
' strive4peace2008 at yahoo.com
'PARAMETERS
' Obj can be a database, a Tabledef, a Field...
' if it is missing, CurrentDb is used
'
If obj Is Nothing Then Set obj = CurrentDb
Dim prp As DAO.Property
Dim i As Integer
i = 0
On Error Resume Next
For Each prp In obj.Properties
If bCustom Then
If Left(prp.Name, 7) <> "Default" Then GoTo NextPrp
End If
Debug.Print Format(i, "000 ") & prp.Name;
Debug.Print " = ", prp.value
i = i + 1
NextPrp:
Next prp
Set prp = Nothing
End Sub
'~~~~~~~~~~~~~~~~~~~~~ ShowPropValueForName
'
'display value of the passed property
'
Public Sub ShowPropValueForName(pPropName As String)
MsgBox pPropName & " is " _
& CurrentDb.Properties(pPropName) _
& " for this database", , "Done"
End Sub
'******************************************************
' EXAMPLES
'******************************************************
' to show how you can get and set a database property
'
'get the value of DefaultMainID
Public Function GetDefaultMainID() As Long
GetDefaultMainID = Nz(CurrentDb.Properties("DefaultMainID"), 0)
End Function
'
'set the value of DefaultMainID, pass an value
Public Sub SetDefaultMainID(pMainID As Long)
'use the passed value to set a database property called MainID
Set_Property "DefaultMainID", dbLong, pMainID, , False
'update a table with the value of the MainID
Dim s As String
s = "UPDATE Tablename SET fieldname =" & pMainID & ";"
CurrentDb.Execute s
End Sub
'
' example to show how to use Delete_Property
'~~~~~~~~~~~~~~~~~~~~~ RunDeleteDatabaseProperty
Public Sub RunDeleteDatabaseProperty()
Dim mPropName As String
mPropName = "DefaultUserID"
Delete_Property mPropName
MsgBox mPropName & " has been deleted", , "Done"
End Sub
'******************************************************
' and for good measure ...
'******************************************************
'
'*****************************
' show or Hide the Database Window
' (not related to properties, but it is here <smile>)
'
'~~~~~~~~~~~~~~~~~~~~~ DB Window
Public Sub HideDBWindow()
DoCmd.SelectObject acTable, "tablename", True
RunCommand acCmdWindowHide
End Sub
Public Sub UnHideDBWindow()
DoCmd.SelectObject acTable, "tablename", True
End Sub
________________________________
From: Clive <zctek@aol.com>
To: MS_Access_Professionals@yahoogroups.com
Sent: Monday, April 9, 2012 12:20 PM
Subject: [MS_AccessPros] Can Custom Databaseb.Property be Deleted
Hi All,
I unintentionally created a Custom Property.
Is there a way of deleting it with VBA?
Clive.
------------------------------------
Yahoo! Groups Links
[Non-text portions of this message have been removed]
Tidak ada komentar:
Posting Komentar