______  __    __       ___      .__   __.   _______  _______     __    ______   ______   .__   __. 
 /      ||  |  |  |     /   \     |  \ |  |  /  _____||   ____|   |  |  /      | /  __  \  |  \ |  | 
|  ,----'|  |__|  |    /  ^  \    |   \|  | |  |  __  |  |__      |  | |  ,----'|  |  |  | |   \|  | 
|  |     |   __   |   /  /_\  \   |  . `  | |  | |_ | |   __|     |  | |  |     |  |  |  | |  . `  | 
|  `----.|  |  |  |  /  _____  \  |  |\   | |  |__| | |  |____    |  | |  `----.|  `--'  | |  |\   | 
 \______||__|  |__| /__/     \__\ |__| \__|  \______| |_______|   |__|  \______| \______/  |__| \__| 
                                                                                                     

تغيير شعار ميكروسوفت أكسس في TASK Manager في النموذج المرفق واستبداله بأيقونة أخرى

يتم استدعاء الروتين من  خلال وضع الكود الاتى فى حدث عند تحميل نموذج

  Call Xicon

مع مراعاة تغيير البيانات الاتية فى رأس الموديول

اسم التطبيق AppName
اسم الايقونة بدون الامتداد icoName
وتم عمل الكود على ان الايقونة فى نفس مسار القاعدة فى حالة تغيير مكان الايقونة لابد من تغير المسار فى الروتين  AppIcon()

Const AppName = "www.officena.net"
Const icoName = "officenaIco"

Public Function AppIcon()
  AppIcon = CurrentProject.Path & "\" & icoName & ".ico"
End Function

Public Function AccessIcon()
  AccessIcon = (SysCmd(acSysCmdAccessDir) & "MSACCESS.EXE")
  Debug.Print AccessIcon
End Function

Function AddAppProperty(strName As String, _
        varType As Variant, varValue As Variant) As Integer
    Dim dbs As Object, prp As Variant
    Const conPropNotFoundError = 3270

    Set dbs = CurrentDb
    On Error GoTo AddProp_Err
    dbs.Properties(strName) = varValue
    AddAppProperty = True

AddProp_Bye:
    Exit Function

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

Function Xicon()
On Error GoTo ErrHandler

Dim dbs As Object
Set dbs = CurrentDb()

Dim intX As Integer
    Const DB_Text As Long = 10
    ' AppTitle
    intX = AddAppProperty("AppTitle", DB_Text, AppName)
    
    ' AppIcon
    Dim Chk
    Dim MyIcon As String
    Set Chk = CreateObject("Scripting.FileSystemObject")
    If Chk.FileExists(AppIcon()) = False Then
    MyIcon = (SysCmd(acSysCmdAccessDir) & "MSACCESS.EXE")
    Else
    MyIcon = AppIcon()
    End If
    
    intX = AddAppProperty("AppIcon", DB_Text, MyIcon)
    dbs.Properties("UseAppIconForFrmRpt") = 1
    Application.RefreshTitleBar
exitProc:
Exit Function
ErrHandler:
    If Err = 3270 Then
        Resume Next
    Else
        MsgBox Err & Err.Description
        Resume exitProc
    End If
End Function

---------------------------------------------------------------------