When ever I send out a newly created app. I sometimes forgot to incl. a ref to the app icon, not showing the database window etc. Clients would call me up and complain that a new window was there, and when they would close this window, the app would close on them, very annoying for them (and me) :-(
And worst of all they were right ;-)
An error like this you only want to see once, if ever, so I created this little function to take care of this for me.
I incl. a ref to it in the the function that I use to start my app.
DAO/MDB solution:
Function CopyRight()
On Error GoTo Fejl
Dim DB As DAO.Database
Set DB = CurrentDb
CopyRight = DB.Properties!CopyRightNotice & " 2000" & " - " & Year(Now)
Exit_Fejl:
Exit Function
Fejl:
If Err.Number <> 3270 Then MsgBox Err.Description , , Your App
If Err.Number = 3270 Then CopyRightMake
Resume Exit_Fejl
End Function
Function CopyRightMake()
'On Error Resume Next
Dim DB As DAO.Database
Dim P As Property
Set DB = DBEngine(0)(0)
Set P = DB.CreateProperty("CopyrightNotice", DB_TEXT, "¬ Your App")
DB.Properties.Append P
Set P = DB.CreateProperty("AppTitle", dbText, "Your App Name")
DB.Properties.Append P
Set P = DB.CreateProperty("AppIcon", dbText, "C:\Program Files\YourApp\Your.ico")
DB.Properties.Append P
Set P = DB.CreateProperty("StartUpShowDBWindow", dbBoolean, False)
DB.Properties.Append P
Set P = DB.CreateProperty("AllowBreakIntoCode", dbBoolean, False)
DB.Properties.Append P
Set P = DB.CreateProperty("AllowSpecialKeys", dbBoolean, False)
DB.Properties.Append P
Set P = DB.CreateProperty("AllowBuiltInToolbars", dbBoolean, False)
DB.Properties.Append P
Set P = DB.CreateProperty("AllowFullMenus", dbBoolean, False)
DB.Properties.Append P
Set P = DB.CreateProperty("AllowShortcutMenus", dbBoolean, False)
DB.Properties.Append P
Set P = DB.CreateProperty("AllowToolbarChanges", dbBoolean, False)
DB.Properties.Append P
End Function
ADO/ADP solution:
Function CopyRight()
Dim DBS As CurrentProject
On Error GoTo Fejl
Set DBS = Application.CurrentProject
CopyRight = DBS.Properties!CopyRightNotice & " 2000" & " - " & Year(Now)
Exit_Fejl:
Exit Function
Fejl:
If Err <> 3265 Then MsgBox Err.Description Else CopyRightMake
Resume Exit_Fejl
End Function
Function CopyRightMake()
Dim DBS As CurrentProject
Dim prp As ADODB.Property
On Error GoTo ErrorHandler
Set DBS = Application.CurrentProject
'Try to set the property, if it fails, the property does not exist.
DBS.Properties("CopyRightNotice") = "¬ Your App"
DBS.Properties("AppTitle") = "Your App Name"
DBS.Properties("AppIcon") = "C:\Program Files\YourApp\Your.ico"
DBS.Properties("StartUpShowDBWindow") = False
DBS.Properties("AllowSpecialKeys") = False
DBS.Properties("AllowBuiltInToolbars") = False
DBS.Properties("AllowFullMenus") = False
DBS.Properties("AllowShortcutMenus") = False
DBS.Properties("AllowToolbarChanges") = False
Application.RefreshTitleBar
ExitLine:
Set DBS = Nothing
Set prp = Nothing
Exit Function
ErrorHandler:
If Err = 2455 Then ' Create the new property.
DBS.Properties.Add "CopyRightNotice", "¬ Your App"
Resume Next
Else
Resume ExitLine
End If
End Function
I drop my copyright notice on my main, if I use such, and in my "about" forms.
