Sub SetObjProp(obj As Object, PropName$, pValue)
'Set the value of an object's property
If IsObjProp(obj, PropName) Then
If Len(pValue & "") Then
obj.Properties(PropName) = pValue
Else
obj.Properties.Delete PropName
End If
Else
If Len(pValue & "") Then
obj.Properties.Append obj.CreateProperty(PropName, DbType(pValue), pValue)
End If
End If
End Sub
|
Option Compare Database
Option Explicit
Sub SetObjProp(obj As Object, PropName$, pValue)
'Set the value of an object's property
If IsObjProp(obj, PropName$) Then
If Len(pValue & "") Then
obj.Properties(PropName$) = pValue
Else
obj.Properties.Delete PropName$
End If
Else
If Len(pValue & "") Then
obj.Properties.Append obj.CreateProperty(PropName$, DbType(pValue), pValue)
End If
End If
End Sub
Public Function GetObjProp(obj As Object, PropName$, DefaultValue) As Variant
'Get the value of an object's property
On Error Resume Next
t = obj.Properties(PropName$)
If Len(t & "") = 0 Then t = DefaultValue
GetObjProp = t
End Function
Sub DelObjProp(obj As Object, PropName$)
'Delete an object's property
On Error Resume Next
obj.Properties.Delete PropName$
End Sub
Public Function IsObjProp(obj As Object, PropName$) As Boolean
'Determine if an object's property exists
On Error Resume Next
t = obj.Properties(PropName$)
IsObjProp = (Err.Number = 0)
End Function
Public Function DbType(vbVariable) As Long
'Returns the database type of a VBA value
Select Case varType(vbVariable)
Case vbByte
DbType = dbByte
Case vbString
DbType = dbText
Case vbBoolean
DbType = dbBoolean
Case vbInteger
DbType = dbInteger
Case vbLong
DbType = dbLong
Case vbSingle
DbType = dbSingle
Case vbDouble
DbType = dbDouble
Case vbCurrency
DbType = dbCurrency
Case vbDate
DbType = dbDate
End Select
End Function
|
Public Function sjmNewObjName(OrigName As String, DocType As ObjType_Enum) As String
'Returns a unique, validated object name.
'When OrigName already exists, a number is appended,
'then the name is re-checked. The generated name
'is returned when it's unique.
'Requires: sjmLegalObjName, sjmValidObjectName (below)
Dim rtn As String
Dim tmp As String
Dim i As Long
'
If IsNumeric(Right$(OrigName, 1)) Then
i = CLng(Right$(OrigName, 1))
tmp = Left$(OrigName, Len(OrigName) - 1)
Else
tmp = OrigName
End If
rtn = OrigName
Do Until sjmLegalObjName(DocType, rtn)
i = i + 1
rtn = tmp & i
Loop
sjmNewObjName = rtn
End Function
Public Function sjmLegalObjName(ObjType As ObjType_Enum, objName As String) As Boolean
'Returns True when objName is valid and
'it doesn't exist in this database.
Dim ctr As String
Dim i As Long
Dim rtn As Boolean
'
If Not sjmValidObjectName(objName) Then
MsgBox "Not a valid Object name. Refer to naming rules in Access help.", vbExclamation
Exit Function
End If
'
With DBEngine(0)(0)
Select Case ObjType
Case acTable
ctr = "Tables"
Case Else
ctr = Choose(ObjType, "Tables", "Forms", "Reports", "Scripts", "Modules")
End Select
rtn = True
With .Containers(ctr)
.Documents.Refresh
For i = 0 To .Documents.Count - 1
If .Documents(i).Name = objName Then
rtn = False
Exit For
End If
Next
End With
End With
sjmLegalObjName = rtn
End Function
Private Function sjmValidObjectName(stName As String) As Boolean
'Returns True if stName doesn't contain any bad chars
'and is <= the max length allowed.
Const MAX_CHARS = 64
'
Dim i As Long
Dim ch As String
Dim rtn As Long
Dim cch As Long
Dim AscCh As Long
'
cch = Len(stName)
If cch = 0 Then
rtn = False
ElseIf cch > MAX_CHARS Then
rtn = False
Else
rtn = True
For i = 1 To cch
ch = Mid$(stName, i, 1)
If i = 1 Then
If ch = " " Or ch = "=" Then
rtn = False
End If
End If
If (InStr(1, "!.[]`'", ch) > 0) Then
rtn = False
End If
AscCh = Asc(ch)
If AscCh >= 0 And AscCh < 32 Then rtn = False
If Not rtn Then Exit For
Next
End If
'
sjmValidObjectName = rtn
End Function
Public Function sjmNewControlName(frmRpt As Object, ctlName As String) As String
'Returns an Access Control name unique to this form or report.
'When ctlName already exists, numbers are appended,
'then the name is re-checked. The generated name
'is returned when it's unique.
'Requires: sjmLegalControlName (below)
Dim rtn As String
Dim tmp As String
Dim i As Long
'
If IsNumeric(Right$(ctlName, 1)) Then
i = CLng(Right$(ctlName, 1))
tmp = Left$(ctlName, Len(ctlName) - 1)
Else
tmp = ctlName
End If
rtn = ctlName
Do Until sjmLegalControlName(frmRpt, rtn)
i = i + 1
rtn = tmp & i
Loop
sjmNewControlName = rtn
End Function
Public Function sjmLegalControlName(frmRpt As Object, ctlName As String) As Boolean
'Returns True when ctlName is valid and
'it doesn't exist in this form or report.
'Requires: sjmValidObjectName (above)
Dim item As Access.Control
If Not sjmValidObjectName(ctlName) Then
MsgBox "Not a valid Control name. Refer to naming rules in Access help.", vbExclamation
Exit Function
End If
For Each item In frmRpt.Controls
If item.Name = ctlName Then
Exit Function
End If
Next
sjmLegalControlName = True
End Function
|