access2010 アプリケーションアイコンの設定

Option Compare Database
Option Explicit

Sub SetAppIcon()
On Error GoTo ErrHnd
    Dim curPath As String
    Dim iconName As String, iconFullPath As String
    Dim rs As DAO.Recordset, rsPct As DAO.Recordset
    
    curPath = Application.CurrentProject.Path
    iconName = "logo"
    iconFullPath = curPath & "\" & iconName & ".ico"
    
    If Len(Dir(iconFullPath)) = 0 Then
        Set rs = CurrentDb.OpenRecordset( _
                "select Data from MSysResources where Name='" & _
                iconName & "';")
                'a2007なら添付ファイルありのテーブル使うべな
        Set rsPct = rs("Data").Value
        rsPct("FileData").SaveToFile iconFullPath
    End If
    
    ChangeProperty "AppIcon", dbText, iconFullPath
    ChangeProperty "UseAppIconForFrmRpt", dbBoolean, True
    Application.RefreshTitleBar
Exit Sub
ErrHnd:
    MsgBox Error$
End Sub

Function ChangeProperty(strPropName As String, _
    varPropType As Variant, _
    varPropValue As Variant) As Integer

    Dim dbs As Object, prp As Variant
    Const conPropNotFoundError = 3270

    Set dbs = CurrentDb
    On Error GoTo Change_Err
    dbs.Properties(strPropName) = varPropValue
    ChangeProperty = True

Change_Bye:
    Exit Function

Change_Err:
    If Err = conPropNotFoundError Then
        Set prp = dbs.CreateProperty(strPropName, _
            varPropType, varPropValue)
        dbs.Properties.Append prp
        Resume Next
    Else
        ChangeProperty = False
        Resume Change_Bye
    End If
End Function