home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / Create Sho25979952001.psc / Modules / ModShortcut.bas
Encoding:
BASIC Source File  |  2001-09-06  |  2.3 KB  |  63 lines
  1. Attribute VB_Name = "ModShortcut"
  2. Private Declare Function fCreateShellLink Lib "VB5STKIT.DLL" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArguments As String) As Long
  3. Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
  4. Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
  5.  
  6. Private Type SHFILEOPSTRUCT
  7.     hwnd As Long
  8.     wFunc As Long
  9.     pFrom As String
  10.     pTo As String
  11.     fFlags As Integer
  12.     fAnyOperationsAborted As Boolean
  13.     hNameMappings As Long
  14.     lpszProgressTitle As String '  only used if FOF_SIMPLEPROGRESS
  15. End Type
  16.  
  17. Private Const FO_MOVE = &H1
  18. Const FOF_RENAMEONCOLLISION = &H8
  19.  
  20. Public Function CreateFileShortcut(ByVal SrcFile As String, ByVal DestDir As String, ByVal DestFile As String, ByVal CalledHwnd As Long) As Boolean
  21. 'On Error GoTo FAILED
  22.  
  23. 'Make Sure The Destdir Has A "\" On the end
  24.   If Not (Right(DestDir, 1) = "\") Then DestDir = (DestDir & "\")
  25. 'Make sure destfile hasn't a ".lnk" on the end
  26.   If LCase(Right(DestFile, 4)) = ".lnk" Then DestFile = Left(DestFile, Len(DestFile) - 4)
  27.  
  28. 'Create the file in the startmenu
  29.   Dim lRet As Long
  30.   lRet = fCreateShellLink("", DestFile, SrcFile, "")
  31.   
  32.   If lRet Then 'if successfull then
  33.     
  34.   'Move the file to the dest folder
  35.     Dim udtFileOp As SHFILEOPSTRUCT
  36.     'Dim MoveFrom As String
  37.     'Dim MoveTo As String
  38.     udtFileOp.hwnd = CalledHwnd
  39.     udtFileOp.wFunc = FO_MOVE
  40.     udtFileOp.pFrom = GetWinDir & "\start menu\programs\" & DestFile & ".lnk"
  41.     udtFileOp.pTo = DestDir & DestFile & ".lnk"
  42.     udtFileOp.fFlags = FOF_RENAMEONCOLLISION
  43.     'Call FileCopy(MoveFrom, MoveTo)
  44.     'Kill MoveFrom
  45.     lRet = SHFileOperation(udtFileOp)
  46.     If lRet <> 0 And Not udtFileOp.fAnyOperationsAborted Then Exit Function
  47.   Else
  48.     Exit Function
  49.   End If
  50. 'Everything is complete, so return True
  51.   CreateFileShortcut = True
  52.  
  53. FAILED: 'Failed the function, so exit
  54. End Function
  55.  
  56. Public Function GetWinDir() As String
  57. Dim WinDir As String * 255
  58. Dim DirLen As Long
  59.  
  60. DirLen = GetWindowsDirectory(WinDir, 255)
  61. GetWinDir = Left(WinDir, DirLen)
  62. End Function
  63.