______ __ __ ___ .__ __. _______ _______ __ ______ ______ .__ __.
/ || | | | / \ | \ | | / _____|| ____| | | / | / __ \ | \ | |
| ,----'| |__| | / ^ \ | \| | | | __ | |__ | | | ,----'| | | | | \| |
| | | __ | / /_\ \ | . ` | | | |_ | | __| | | | | | | | | | . ` |
| `----.| | | | / _____ \ | |\ | | |__| | | |____ | | | `----.| `--' | | |\ |
\______||__| |__| /__/ \__\ |__| \__| \______| |_______| |__| \______| \______/ |__| \__|
تغيير شعار ميكروسوفت أكسس في 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
---------------------------------------------------------------------