codice:
Option Explicit
Private Const kQuote = """"
Private Const kEmptyString = ""
Private Const kMaxPathLength = 260 ' Maximum allowed path & filename length.
Private Const kMaxGroupNameLength = 30 ' NT Maximum length that we allow For an group name.
Private Const kInvalid95GroupNameChars = "\/:*?""<>|" ' Invalid Windows 95 Group Name Characters.
Private Const kInvalidNTGroupNameChars = """][,)(" ' Invalid Windows NT Group Name Characters.
Private Const kDesktopGroup = "..\..\DESKTOP" ' Desktop Group.
Private Const kStartMenuGroup = ".." ' Start Menu Group.
Private Const kQuickMenuGroup = "..\..\Application Data\Microsoft\Internet Explorer\Quick Launch" ' Quick Menu Group.
'PROGRAM MANAGER ACTIONS'
Const kDDE_AddItem = 1 'AddProgManItem flag
Const kDDE_AddGroup = 2 'AddProgManGroup flag
Declare Function GetWinPlatform Lib "VB5STKIT.DLL" () As Long
Declare Function fNTWithShell Lib "VB5STKIT.DLL" () As Boolean
Private Declare Function OSGetShortPathName Lib "kernel32" _
Alias "GetShortPathNameA" (ByVal lpszLongPath As String, _
ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
'Shortcut - Create: Group & Link, Delete: Link
Declare Function OSfCreateShellGroup Lib "VB5STKIT.DLL" _
Alias "fCreateShellFolder" (ByVal lpstrDirName As String) As Long
Declare Function OSfCreateShellLink Lib "VB5STKIT.DLL" _
Alias "fCreateShellLink" (ByVal lpstrFolderName As String, _
ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, _
ByVal lpstrLinkArguments As String) As Long
Declare Function OSfRemoveShellLink Lib "VB5STKIT.DLL" _
Alias "fRemoveShellLink" (ByVal lpstrFolderName As String, _
ByVal lpstrLinkName As String) As Long
Public Sub CreateShortcut(ByRef frm As Form, _
ByVal strGroupName As String, _
ByVal strLinkName As String, _
ByVal strLinkPath As String, _
ByVal strLinkArguments As String)
If fCreateProgGroup(frm, strGroupName) Then
If TreatAsWin95() Then
CreateShellLink strLinkPath, strGroupName, strLinkArguments, strLinkName
Else
strLinkPath = GetShortPathName(strUnQuoteString(strLinkPath))
CreateProgManItem frm, strGroupName, strLinkPath & " " & strLinkArguments, strLinkName
End If
End If
End Sub
Private Sub CreateShellLink(ByVal strLinkPath As String, ByVal strGroupName As String, ByVal strLinkArguments As String, ByVal strLinkName As String)
strLinkName = strUnQuoteString(strLinkName)
strLinkPath = strUnQuoteString(strLinkPath)
Dim fSuccess As Boolean
fSuccess = OSfCreateShellLink(strGroupName & "", strLinkName, strLinkPath, strLinkArguments & "")
If Not fSuccess Then
MsgBox "Creazione collegamento fallita!", vbExclamation, "Errore!"
End If
End Sub
Private Sub CreateProgManItem(frm As Form, ByVal strGroupName As String, ByVal strCmdLine As String, ByVal strIconTitle As String)
PerformDDE frm, strGroupName, strCmdLine, strIconTitle, kDDE_AddItem
End Sub
Private Sub PerformDDE(frm As Form, ByVal strGroup As String, ByVal strCmd As String, ByVal strTitle As String, ByVal intDDE As Integer)
Const strCOMMA$ = ","
Const strRESTORE$ = ", 1)]"
Const strACTIVATE$ = ", 5)]"
Const strENDCMD$ = ")]"
Const strSHOWGRP$ = "[ShowGroup("
Const strADDGRP$ = "[CreateGroup("
Const strREPLITEM$ = "[ReplaceItem("
Const strADDITEM$ = "[AddItem("
Dim intIdx As Integer 'loop variable
Screen.MousePointer = vbHourglass
Dim intRetry As Integer
For intRetry = 1 To 20
On Error Resume Next
frm.lblDDE.LinkTopic = "PROGMAN|PROGMAN"
If Err = 0 Then
Exit For
End If
DoEvents
Next intRetry
frm.lblDDE.LinkMode = 2
For intIdx = 1 To 10
DoEvents
Next
frm.lblDDE.LinkTimeout = 100
On Error Resume Next
If Err = 0 Then
Select Case intDDE
Case kDDE_AddItem
#If 0 Then
frm.lblDDE.LinkExecute strSHOWGRP & strGroup & strACTIVATE
#Else
frm.lblDDE.LinkExecute strADDGRP & strGroup & strENDCMD
#End If
frm.lblDDE.LinkExecute strREPLITEM & strTitle & strENDCMD
Err = 0
frm.lblDDE.LinkExecute strADDITEM & strCmd & strCOMMA & strTitle & String$(3, strCOMMA) & strENDCMD
Case kDDE_AddGroup
frm.lblDDE.LinkExecute strADDGRP & strGroup & strENDCMD
frm.lblDDE.LinkExecute strSHOWGRP & strGroup & strRESTORE
'End Case
End Select
End If
frm.lblDDE.LinkMode = 0
frm.lblDDE.LinkTopic = ""
Screen.MousePointer = vbDefault
Err = 0
End Sub
Private Function fCreateProgGroup(frm As Form, sNewGroupName As String) As Boolean
If UCase(Trim(sNewGroupName)) = kDesktopGroup Or sNewGroupName = kStartMenuGroup Or sNewGroupName = kQuickMenuGroup Then
fCreateProgGroup = True
Exit Function
Else
If TreatAsWin95() Then
'WINDOWS 95/98
If Not fValid95Filename(sNewGroupName) Then
MsgBox "Errore: nome gruppo non valido!", vbQuestion, "Errore"
GoTo CGError
End If
Else
'WINDOWS NT
If Not fValidNTGroupName(sNewGroupName) Then
MsgBox "Error: Could not validate the Program Group name!", vbQuestion, "Error"
GoTo CGError
End If
End If
'CREATE THE WINDOWS 95 OR NT PROGRAM GROUP'
If Not fCreateOSProgramGroup(frm, sNewGroupName) Then
GoTo CGError
End If
fCreateProgGroup = True
End If
Exit Function
CGError:
fCreateProgGroup = False
End Function
Private Function fCreateShellGroup(ByVal strFolderName As String) As Boolean
ReplaceDoubleQuotes strFolderName
If strFolderName = "" Then
Exit Function
End If
Dim fSuccess As Boolean
fSuccess = OSfCreateShellGroup(strFolderName)
If fSuccess Then
Else
MsgBox "Creazione gruppo nel Menu Avvio fallita!", vbExclamation, "Errore!"
End If
fCreateShellGroup = fSuccess
End Function
Private Function fValid95Filename(strFilename As String) As Boolean
Dim iInvalidChar As Integer
Dim iFilename As Integer
If Not ValidateFilenameLength(strFilename) Then
fValid95Filename = False
Exit Function
End If
For iInvalidChar = 1 To Len(kInvalid95GroupNameChars)
If InStr(strFilename, Mid$(kInvalid95GroupNameChars, iInvalidChar, 1)) <> 0 Then
fValid95Filename = False
Exit Function
End If
Next iInvalidChar
fValid95Filename = True
End Function
Public Function fValidNTGroupName(strGroupName) As Boolean
If Len(strGroupName) > kMaxGroupNameLength Then
fValidNTGroupName = False
Exit Function
End If
Dim iInvalidChar As Integer
Dim iFilename As Integer
For iInvalidChar = 1 To Len(kInvalidNTGroupNameChars)
If InStr(strGroupName, Mid$(kInvalidNTGroupNameChars, iInvalidChar, 1)) <> 0 Then
fValidNTGroupName = False
Exit Function
End If
Next iInvalidChar
fValidNTGroupName = True
End Function
Private Function fCreateOSProgramGroup(frm As Form, ByVal strFolderName As String) As Boolean
If TreatAsWin95() Then
'CREATE WINDOWS 95 PROGRAM GROUP'
fCreateOSProgramGroup = fCreateShellGroup(strFolderName)
Else
'CREATE WINDOWS NT PROGRAM GROUP'
CreateProgManGroup frm, strFolderName
fCreateOSProgramGroup = True
End If
End Function
Private Sub CreateProgManGroup(frm As Form, ByVal strGroupName As String)
PerformDDE frm, strGroupName, kEmptyString, kEmptyString, kDDE_AddGroup
End Sub
Private Function TreatAsWin95() As Boolean
If IsWindows95() Then
TreatAsWin95 = True
ElseIf fNTWithShell() Then
TreatAsWin95 = True
Else
TreatAsWin95 = False
End If
End Function
Private Function IsWindows95() As Boolean
Const dwMask95 = &H2&
If GetWinPlatform() And dwMask95 Then
IsWindows95 = True
Else
IsWindows95 = False
End If
End Function
Private Function strUnQuoteString(ByVal strQuotedString As String)
strQuotedString = Trim(strQuotedString)
If Mid$(strQuotedString, 1, 1) = kQuote And Right$(strQuotedString, 1) = kQuote Then
strQuotedString = Mid$(strQuotedString, 2, Len(strQuotedString) - 2)
End If
strUnQuoteString = strQuotedString
End Function
Private Function StripTerminator(ByVal strString As String) As String
Dim intZeroPos As Integer
intZeroPos = InStr(strString, Chr$(0))
If intZeroPos > 0 Then
StripTerminator = Left$(strString, intZeroPos - 1)
Else
StripTerminator = strString
End If
End Function
Private Sub ReplaceDoubleQuotes(str As String)
Dim i As Integer
For i = 1 To Len(str)
If Mid$(str, i, 1) = """" Then
Mid$(str, i, 1) = "'"
End If
Next i
End Sub
Private Function GetShortPathName(ByVal strLongPath As String) As String
Const cchBuffer = 300
Dim strShortPath As String
Dim lResult As Long
On Error GoTo 0
strShortPath = String(cchBuffer, Chr$(0))
lResult = OSGetShortPathName(strLongPath, strShortPath, cchBuffer)
If lResult = 0 Then
Error 53 ' File not found
Else
GetShortPathName = StripTerminator(strShortPath)
End If
End Function
Private Function ValidateFilenameLength(strFilename As String) As Boolean
ValidateFilenameLength = (Len(strFilename) < kMaxPathLength)
End Function
in un form:
codice:
Dim game As String
Private Sub Command1_Click()
game = "AZZ"
Call CreateShortcut(Me, game, game, "c:\programmi\azz.exe", "") 'GRUPPO PROGRAMMI
'Call CreateShortcut(Me, game, "Config", txtDestPath.Text & "\" & exelink1, "") 'GRUPPO PROGRAMMI
'Call CreateShortcut(Me, "..\..\Desktop", game, txtDestPath.Text & "\" & exelink, "") 'DESKTOP
End Sub
la libreria 
Permessi di invio
Rispondi quotando