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

[علياء يسرالدين]

السلام عليكم .. ارجو المساعدة في إخغاء شعار أكسس في شريط المهام .. بحثت ووجدت الكود في النموذج المرفق ولكن لم أفلح . لدي اوفيس 32بت 2007..الله يعافيكم

testIcon.rar

[ابو جودي]

في ١٧‏/١١‏/٢٠٢١ at 22:48, علياء يسرالدين said:

السلام عليكم .. ارجو المساعدة في إخغاء شعار أكسس في شريط المهام 

وعليكم السلام

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

  Call Xicon

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

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

Const AppName = "Alia Yusr El Din"
Const icoName = "4"

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

 

 

testIcon.zip

[User user]

1 ساعه مضت, ابو جودي said:

وعليكم السلام

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

  Call Xicon

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

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

Const AppName = "Alia Yusr El Din"
Const icoName = "4"

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

 

 

testIcon.zip 28.17 kB · 3 downloads

للاسف تظهر كما هى فى ويندوز 8 الى ما فوق ذلك 

[AliAli47]

في ١٧‏/١١‏/٢٠٢١ at 21:48, علياء يسرالدين said:

السلام عليكم .. ارجو المساعدة في إخغاء شعار أكسس في شريط المهام .. بحثت ووجدت الكود في النموذج المرفق ولكن لم أفلح . لدي اوفيس 32بت 2007..الله يعافيكم

testIcon.rar 20.72 kB · 8 downloads

غير امتداد الملف من accdb الى accdr 

 

[Moosak]

أسهل طريقة لإخفاء شعار الأكسس وإظهار شعارك الخاص على البرنامج وبدون أكواد هو كتابة اسم الأيقونة بهذه الطريقة .. وتكون دائما بجانب ملف الأكسس :

 

وبالتعليم على خيار (الاستخدام كأيقونة نموذج وتقرير ) ستظهر لك حتى على نوافذ النمانج والتقارير ..

تم تعديل نوفمبر 29, 2021 بواسطه Moosak