Creating shortcuts of application

[paralinx]

Hi all,

Is there anyway to make a shortcut of a program that will run like the original, but is on the desktop? I need to do this because my program relies on two text files that I have in App.Path, and If i put it on the desktop I will need to put the folders on the desktop too and that won't work.


Does anyone know if this is possible?

[randem]

Select your program in Windows Explorer then right click and create shortcut. Move it to the desktop or create it to the desktop.

[|2eM!x]

Private Declare Function fCreateShellLink Lib "VB5STKIT.DLL" _
    (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, _
    ByVal lpstrLinkPath As String, ByVal lpstrLinkArgs As String) As Long
 
dim lngRslt as long
 
lngRslt = fCreateShellLink("..\..\Desktop", ShortCutName, App.Path & "\exe.exe", (properties))

[paralinx]

Great thanks to both

[RhinoBull]

Here is what I use (written awhile ago) to create shortcurs on the desktop (you may need to add some logic to check if it altready exist but it isn't really necessary):

Option Explicit
 
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 SHGetSpecialFolderLocation Lib "shell32.dll" _
                        (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As Long) 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)
 
Private Const ERROR_SUCCESS = 0&
Private Const CSIDL_DESKTOPDIRECTORY = &H10       '{user}\Desktop
 
Private Sub Form_Load()
'============================
Dim strLinkName As String
Dim strFullPath As String
Dim strComLineArgs As String
Dim bPrivate As Boolean
Dim strParent As String
 
    strLinkName = App.EXEName & ".exe"
    strFullPath = App.Path & "\" & App.EXEName & ".exe"
    strComLineArgs = ""
    bPrivate = True
    strParent = "$(Programs)"
    
    CreateShortcut strLinkName, strFullPath, strComLineArgs, bPrivate, strParent
 
End Sub
 
Private Sub CreateShortcut(strLinkName As String, _
                           strFullPath As String, _
                           strComLineArgs As String, _
                           bPrivate As Boolean, _
                           strParent As String)
'======================================================
Dim sDeskPath As String
Dim Pos As Integer
Dim strDestination As String
 
On Error Resume Next
 
    sDeskPath = GetSpecialFolder(Me.hwnd, CSIDL_DESKTOPDIRECTORY)
    Pos = InStrRev(sDeskPath, "\")
    strDestination = "..\.." & Mid(sDeskPath, Pos)
    
    OSfCreateShellLink strDestination, strLinkName, strFullPath, _
                       strComLineArgs, bPrivate, strParent
 
End Sub
 
Public Function GetSpecialFolder(hwnd As Long, CSIDL As Long) As String
'========================================================================
Dim pidl As Long
Dim Pos As Long
Dim sPath As String
     
    '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
    
End Function

[paralinx]

One more question. How could I set all of the selected items in a file list box into an array? I tried this but only got the first item selected.

Private Sub cmdCopyTo_Click()
    Dim i As Integer
    If File1.ListIndex < 0 Then
        MsgBox "No Selected Songs.", vbCritical
        Exit Sub
    End If
    ReDim sFileName(File1.ListIndex - 1)
    For i = 0 To UBound(sFileName)
        sFileName(i) = File1.Path
        If Right$(sFileName(i), 1) <> "\" Then
            sFileName(i) = sFileName(i) & "\"
        End If
        sFileName(i) = sFileName(i) [COLOR=Red]& File1.Filename[/COLOR]
    Next i
    blnCopy = True
End Sub

I'm pretty sure that the part in red is what is wrong. But I can't figure out how to get the first, second, third, ect file name in the file list box

[RhinoBull]

Here is modified version (untested) so give it the try and let em know if works for you:

Private Sub Command1_Click()
Dim i As Integer
 
    If File1.ListIndex < 0 Then
        MsgBox "No Selected Songs.", vbCritical
        Exit Sub
    End If
    
    ReDim sFileName(0)
    blnCopy = False
    
    For i = 0 To File1.ListCount - 1
        If File1.Selected(i) = True Then
            sFileName(UBound(sFileName)) = File1.List(i)
            ReDim Preserve sFileName(UBound(sFileName) + 1)
        End If
    Next i
    If UBound(sFileName) > 0 Then
        If Trim(sFileName(UBound(sFileName))) = "" Then
            ReDim Preserve sFileName(UBound(sFileName) - 1)
        End If
    End If
    If Trim(sFileName(0)) <> "" Then
        blnCopy = True 'not sure what this is for ???
    End If
 
End Sub

[randem]

Use

For i = 0 To File1.ListIndex - 1
 
and
 
If File1.Item(i).Selected Then

[RhinoBull]

Use

For i = 0 To File1.ListIndex - 1

How ListIndex be helpfull in the that loop ?

[randem]

Youre right I did not look properly at the portion of the line I copied from the original code. I assumed he had it right... Incorrectly I add

[paralinx]

Here is modified version (untested) so give it the try and let em know if works for you:

Private Sub Command1_Click()
Dim i As Integer
 
    If File1.ListIndex < 0 Then
        MsgBox "No Selected Songs.", vbCritical
        Exit Sub
    End If
    
    ReDim sFileName(0)
    blnCopy = False
    
    For i = 0 To File1.ListCount - 1
        If File1.Selected(i) = True Then
            sFileName(UBound(sFileName)) = File1.List(i)
            ReDim Preserve sFileName(UBound(sFileName) + 1)
        End If
    Next i
    If UBound(sFileName) > 0 Then
        If Trim(sFileName(UBound(sFileName))) = "" Then
            ReDim Preserve sFileName(UBound(sFileName) - 1)
        End If
    End If
    If Trim(sFileName(0)) <> "" Then
        blnCopy = True 'not sure what this is for ???
    End If
 
End Sub

Ok, I should have just asked this to, but I need the directory of the file list box infront of the names.

[paralinx]

Ok, sorry I have so many questions on one thread, but how come I have no "FileSystemObject" in my references?

I'm trying to use this code

'Set A Reference To FileSystemObject
 
Private Function FileCount(ByVal FolderName As String) As Long
Dim objFS As New Scripting.FileSystemObject
Dim objFolder As Scripting.Folder
 
If objFS.FolderExists(FolderName) Then
    Set objFolder = objFS.GetFolder(FolderName)
    'if this lines returns more than 0, the folder has files
    FileCount = objFolder.Files.Count
End If
 
Set objFolder = Nothing
Set objFS = Nothing
 
End Function
 
Private Sub cmdCheckForFiles_Click()
MsgBox FileCount("C:\windows\system")
End Sub

[RhinoBull]

Sorry paralinx but I don't quite follow you - maybe it's time for you to split this thread ...

[dglienna]

Look for Microsoft Scripting Runtime in components.

[Hack]

Look for Microsoft Scripting Runtime in components.

Actually, it is a reference.