السلام عليكم ورحمة الله
في احد المواضيع طلب كيفية عمل ستيرش كت وجاوب الاخ محمد السيد بكيفية عمل سترش كت للبرنامج ووضع مرفق
لكن انا لم افهم من اكواده شيئا لذلك اتمنى تشرحوا لي هذا الكود :
Option Explicit Private Const CSIDL_PROGRAMS = &H2 'Start Menu\Programs Private Const CSIDL_STARTUP = &H7 Private Const ERROR_SUCCESS = 0& Private Const CSIDL_DESKTOPDIRECTORY = &H10 Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As Long) As Long Private Declare Function OSfCreateShellLink Lib "vb6stkit.dll" Alias "fCreateShellLink" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArguments As String, ByVal fPrivate As Long, ByVal sParent As String) As Long Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long) Public Function GetSpecialFolder(hWnd As Long, CSIDL As Long) As String Dim pidl As Long Dim Pos As Long Dim sPath As String On Error GoTo ErrHandler 'fill the pidl with the specified folder item If SHGetSpecialFolderLocation(hWnd, CSIDL, pidl) = ERROR_SUCCESS Then 'initialize & get the path sPath = Space$(260) If SHGetPathFromIDList(ByVal pidl, ByVal sPath) Then 'check for a null Pos = InStr(sPath, Chr$(0)) If Pos Then 'strip it GetSpecialFolder = Left$(sPath, Pos - 1) End If Call CoTaskMemFree(pidl) End If End If Exit Function ErrHandler: Err.Clear Resume Next End Function Public Sub CreateShortCut() Dim sDeskPath As String Dim Pos As Integer Dim strDestination As String Dim strLinkName As String Dim strFullPath As String Dim strComLineArgs As String Dim strPrivate As Boolean Dim strParent As String sDeskPath = GetSpecialFolder(Me.hWnd, CSIDL_DESKTOPDIRECTORY) Pos = InStrRev(sDeskPath, "\") strDestination = "..\.." & Mid(sDeskPath, Pos) strLinkName = App.EXEName & ".exe" strFullPath = App.Path & "\" & App.EXEName & ".exe" strComLineArgs = "" strPrivate = True strParent = "$(Programs)" OSfCreateShellLink strDestination, strLinkName, strFullPath, strComLineArgs, strPrivate, strParent End Sub Private Sub RunAtStartUp() Dim strProgramsFolder As String Dim strStarUpFolder As String Dim FileToKill As String Dim Pos As Integer Dim strDestination As String Dim strLinkName As String Dim strFullPath As String Dim strComLineArgs As String Dim strPrivate As Boolean Dim strParent As String Dim lngKey As Long Dim lngCurKey As Long Dim strSubKey As String Dim strValue As String On Error Resume Next 'get path to the current user's Programs\StarUp folder strProgramsFolder = GetSpecialFolder(Me.hWnd, CSIDL_PROGRAMS) Pos = InStrRev(strProgramsFolder, "\") strProgramsFolder = ".." & Mid(strProgramsFolder, Pos) strStarUpFolder = GetSpecialFolder(Me.hWnd, CSIDL_STARTUP) Pos = InStrRev(strStarUpFolder, "\") strStarUpFolder = Mid(strStarUpFolder, Pos) strStarUpFolder = strProgramsFolder & strStarUpFolder strDestination = strStarUpFolder strLinkName = App.EXEName & ".exe" strFullPath = App.Path & "\" & App.EXEName & ".exe" strComLineArgs = "" strPrivate = True strParent = "$(Programs)" OSfCreateShellLink strDestination, strLinkName, strFullPath, strComLineArgs, strPrivate, strParent End Sub
اتمنى شرح وافي يا شباب بحيث عيوني تصير حمراء من القراءة
