TopPicLogo TopPicText

Иконка и Заголовок Приложения

Private Sub Test_App_Icon_and_Title()
Dim str As String
Dim i As Integer
On Error Resume Next
'Путь к файлу иконки
    str = CurrentProject.Path & "\Application.ico"

'Установка иконки
    AddAppProperty "AppIcon", dbText, str
    Application.RefreshTitleBar
    Err.Clear
'Установка названия приложения
    str = "Пример НАЗВАНИЕ"
    i = AddAppProperty("AppTitle", dbText, str)
    Application.RefreshTitleBar
End Sub


Private Function AddAppProperty(strName As String, vType As Variant, val As Variant) As Integer
'Вспомогательная функция "AddAppProperty" изменяет - добавляет свойства БД
Dim dbs As Database, prp As Property
Const conPropNotFoundError = 3270
'--------------------------------------------------------------------
On Error GoTo AddAppPropertyErr
    Set dbs = CurrentDb
    dbs.Properties(strName) = val
    AddAppProperty = True

AddAppPropertyBye:
    Exit Function

AddAppPropertyErr:
    If Err.Number = conPropNotFoundError Then
        Set prp = dbs.CreateProperty(strName, vType, val)
        dbs.Properties.Append prp
    Else
        AddAppProperty = False
        MsgBox Err
    End If
    Err.Clear
    Resume AddAppPropertyBye
End Function
Назад ToTop
L.E. 25.12.2012
Рейтинг@Mail.ru