هذا هو كود الموديول و لا أدري لماذا لا يتعرف الجهاز على أيقونة البرنامج
Option Explicit
Global NoOfForms
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const ERROR_SUCCESS = 0&
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal Hkey As Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String) As Long
Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal Hkey As Long, ByVal lpValueName As String) As Long
Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal Hkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal Hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Public Declare Function SHChangeNotify Lib "shell32.dll" (ByVal wEventID As Long, _
ByVal uFlags As Long, ByVal dwItem1 As String, ByVal dwItems As String) As Long
Public Const REG_SZ = 1
Public Const REG_DWORD = 4
Private Declare Function SendMessage Lib "user32.dll" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const WM_PAINT = &HF
Private Const WM_PRINT = &H317
Private Const PRF_CLIENT = &H4& ' Draw the window's client area
Private Const PRF_CHILDREN = &H10& ' Draw all visible child
Private Const PRF_OWNED = &H20& ' Draw all owned windows
Public Declare Function DrawMenuBar& Lib "user32" (ByVal hwnd As Long)
Public Declare Function GetMenuItemCount& Lib "user32" (ByVal hMenu As Long)
Public Declare Function GetSystemMenu& Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long)
Public Declare Function RemoveMenu& Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long)
Public Const SHCNE_ASSOCCHANGED = &H8000000
Public Const SHCNF_IDLIST = &H0
Public Const MF_BYPOSITION = &H400
Public Const MF_REMOVE = &H1000
Public Sub savestring(Hkey As Long, strPath As String, strValue As String, strdata As String)
Dim keyhand As Long
Dim r As Long
r = RegCreateKey(Hkey, strPath, keyhand)
r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))
r = RegCloseKey(keyhand)
End Sub
Public Sub AssociateMyApp(ByVal sAppName As String, ByVal sEXE As String, _
ByVal sExt As String, Optional ByVal sCommand As String, _
Optional ByVal sIcon As String)
Dim sCommandString As String
Dim lRegKey As Long
Call RegCreateKey(HKEY_CLASSES_ROOT, "." & sExt, lRegKey)
Call RegSetValueEx(lRegKey, "", 0&, 1, ByVal sAppName, Len(sAppName))
Call RegCloseKey(lRegKey)
sCommand = "\Shell\" & IIf(Len(sCommand), sCommand, "Open") & "\Command"
Call RegCreateKey(HKEY_CLASSES_ROOT, sAppName & sCommand, lRegKey)
Call RegSetValueEx(lRegKey, "", 0&, 1, ByVal sEXE, Len(sEXE))
Call RegCloseKey(lRegKey)
If Len(sIcon) Then
Call RegCreateKey(HKEY_CLASSES_ROOT, sAppName & "\DefaultIcon", lRegKey)
Call RegSetValueEx(lRegKey, "", 0&, 1, ByVal sIcon, Len(sIcon))
Call RegCloseKey(lRegKey)
End If
SHChangeNotify SHCNE_ASSOCCHANGED, SHCNF_IDLIST, vbNullString, vbNullString
End Sub
