I haven't tested this code but a quick scan didn't show any problems with it. It should create three shortcuts in the Start Menu and then rename them:
[tt]
'Module level
Public Type SHFILEOPSTRUCT
hWnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAborted As Boolean
hNameMaps As Long
sProgress As String
End Type
Public Const FO_MOVE = &H1
Public Const FO_RENAME = &H4
Public Const FOF_SILENT = &H4
Public Const FOF_NOCONFIRMATION = &H10
Public Const FOF_FILESONLY = &H80
Public Const FOF_SIMPLEPROGRESS = &H100
Public Const FOF_NOCONFIRMMKDIR = &H200
Public Const SHARD_PATH = &H2&
Public Declare Function SHAddToRecentDocs Lib "shell32.dll" _
(ByVal dwFlags As Long, ByVal dwData As String) As Long
Public Declare Function SHFileOperation _
Lib "shell32.dll" Alias "SHFileOperationA" _
(lpFileOp As SHFILEOPSTRUCT) As Long
Public Declare Function SHGetPathFromIDList _
Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Function SHGetSpecialFolderLocation _
Lib "shell32.dll" _
(ByVal hwndOwner As Long, _
ByVal nFolder As Long, _
pidl As Long) As Long
'Form Level
Option Explicit
Private Sub Command1_Click()
Dim r As Long
Dim i As Integer
Dim FolderPath As String
Dim StartMenuPath As String
Dim fNameOld As String
Dim fNameNew As String
Dim fNames() As String
ReDim fNames(1 To 3) As String
Const CSIDL_RECENT = &H8
Const CSIDL_STARTMENU = &HB
FolderPath = GetSpecialFolder(CSIDL_RECENT)
StartMenuPath = GetSpecialFolder(CSIDL_STARTMENU)
If FolderPath = "" Or StartMenuPath = "" Then
MsgBox "Error retrieving folder paths."
Exit Sub
End If
StartMenuPath = StartMenuPath & "Programs\MyApp\"
'Create shortcuts to these files
fNames(1) = "d:\MyApp\My.exe"
fNames(2) = "d:\MyApp\My.hlp"
fNames(3) = "d:\MyApp\MyReadme.txt"
'First, add them to the recent files list
r = SHAddToRecentDocs(SHARD_PATH, fNames(1))
r = SHAddToRecentDocs(SHARD_PATH, fNames(2))
r = SHAddToRecentDocs(SHARD_PATH, fNames(3))
fNames(1) = FolderPath & "My.exe.lnk"
fNames(2) = FolderPath & "My.hlp.lnk"
fNames(3) = FolderPath & "MyReadme.txt.lnk"
'
Move the shortcuts to the start menu
ShellMoveFiles fNames(), StartMenuPath
'Optionally, you can rename the shortcuts
fNameOld = StartMenuPath & "My.exe.lnk"
fNameNew = StartMenuPath & "New Name for My Exe.lnk"
ShellRenameFile fNameOld, fNameNew
fNameOld = StartMenuPath & "My.hlp.lnk"
fNameNew = StartMenuPath & "New Name for My Help.lnk"
ShellRenameFile fNameOld, fNameNew
fNameOld = StartMenuPath & "MyReadme.txt.lnk"
fNameNew = StartMenuPath & "New Name for My Readme.lnk"
ShellRenameFile fNameOld, fNameNew
End Sub
Private Sub ShellMoveFiles(sFileArray() As String, sDestination As String)
Dim r As Long
Dim i As Integer
Dim sFiles As String
Dim SHFileOp As SHFILEOPSTRUCT
For i = LBound(sFileArray) To UBound(sFileArray)
sFiles = sFiles & sFileArray(i) & Chr$(0)
Next
sFiles = sFiles & Chr$(0)
With SHFileOp
.wFunc = FO_MOVE
.pFrom = sFiles
.pTo = sDestination
.fFlags = FOF_SILENT Or FOF_NOCONFIRMATION Or FOF_NOCONFIRMMKDIR
End With
r = SHFileOperation(SHFileOp)
End Sub
Private Function GetSpecialFolder(CSIDL As Long) As String
Dim sPath As String
Dim pidl As Long
Const ERROR_SUCCESS = 0
Const MAX_LENGTH = 260
If SHGetSpecialFolderLocation(Me.hWnd, CSIDL, pidl)= ERROR_SUCCESS Then
sPath = Space$(MAX_LENGTH)
If SHGetPathFromIDList(ByVal pidl, ByVal sPath) Then
GetSpecialFolder = Left$(sPath, _
InStr(sPath, Chr$(0)) - 1) & "\"
End If
End If
End Function
Private Sub ShellRenameFile(sOldName As String, sNewName As String)
Dim SHFileOp As SHFILEOPSTRUCT
Dim r As Long
sOldName = sOldName & Chr$(0) & Chr$(0)
sNewName = sNewName & Chr$(0) & Chr$(0)
Print sOldName
Print sNewName
With SHFileOp
.wFunc = FO_RENAME
.pFrom = sOldName
.pTo = sNewName
.fFlags = FOF_SILENT Or FOF_NOCONFIRMATION
End With
r = SHFileOperation(SHFileOp)
End Sub
[/tt]
Alt255@Vorpalcom.Intranets.com
