Где взял не помню

AddAppProperty "AppTitle", dbText, "Новый заголовок"
Application.RefreshTitleBar

Public Function AddAppProperty(prpName As String, prpType As Variant, prpValue As Variant) As Integer
Dim dbs As DATABASE, prp As Property
Const conPropNotFoundError = 3270

Set dbs = CurrentDb
On Error GoTo AddProp_Err
dbs.Properties(prpName) = prpValue
AddAppProperty = True

AddProp_Bye:
If Not isNothing(prp) Then Set prp = Nothing
If Not isNothing(dbs) Then Set dbs = Nothing
Exit Function

AddProp_Err:
If Err = conPropNotFoundError Then
Set prp = dbs.CreateProperty(prpName, prpType, prpValue)
dbs.Properties.Append prp
Resume
Else
AddAppProperty = False
Resume AddProp_Bye
End If
End Function

Public Function isNothing(ByVal objName As Object) As Boolean
isNothing = (TypeName(objName) = "Nothing")
End Function