You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
214 lines
9.9 KiB
214 lines
9.9 KiB
VERSION 1.0 CLASS
|
|
BEGIN
|
|
MultiUse = -1 'True
|
|
END
|
|
Attribute VB_Name = "cShellLink"
|
|
Attribute VB_GlobalNameSpace = False
|
|
Attribute VB_Creatable = True
|
|
Attribute VB_PredeclaredId = False
|
|
Attribute VB_Exposed = True
|
|
Option Explicit
|
|
|
|
'---------------------------------------------------------------
|
|
'- Public enums...
|
|
'---------------------------------------------------------------
|
|
Public Enum STGM
|
|
STGM_DIRECT = &H0&
|
|
STGM_TRANSACTED = &H10000
|
|
STGM_SIMPLE = &H8000000
|
|
STGM_READ = &H0&
|
|
STGM_WRITE = &H1&
|
|
STGM_READWRITE = &H2&
|
|
STGM_SHARE_DENY_NONE = &H40&
|
|
STGM_SHARE_DENY_READ = &H30&
|
|
STGM_SHARE_DENY_WRITE = &H20&
|
|
STGM_SHARE_EXCLUSIVE = &H10&
|
|
STGM_PRIORITY = &H40000
|
|
STGM_DELETEONRELEASE = &H4000000
|
|
STGM_CREATE = &H1000&
|
|
STGM_CONVERT = &H20000
|
|
STGM_FAILIFTHERE = &H0&
|
|
STGM_NOSCRATCH = &H100000
|
|
End Enum
|
|
|
|
Public Enum SHELLFOLDERS ' Shell Folder Path Constants...
|
|
CSIDL_DESKTOP = &H0& ' ..\WinNT\profiles\username\Desktop
|
|
CSIDL_PROGRAMS = &H2& ' ..\WinNT\profiles\username\Start Menu\Programs
|
|
CSIDL_CONTROLS = &H3& ' No Path
|
|
CSIDL_PRINTERS = &H4& ' No Path
|
|
CSIDL_PERSONAL = &H5& ' ..\WinNT\profiles\username\Personal
|
|
CSIDL_FAVORITES = &H6& ' ..\WinNT\profiles\username\Favorites
|
|
CSIDL_STARTUP = &H7& ' ..\WinNT\profiles\username\Start Menu\Programs\Startup
|
|
CSIDL_RECENT = &H8& ' ..\WinNT\profiles\username\Recent
|
|
CSIDL_SENDTO = &H9& ' ..\WinNT\profiles\username\SendTo
|
|
CSIDL_BITBUCKET = &HA& ' No Path
|
|
CSIDL_STARTMENU = &HB& ' ..\WinNT\profiles\username\Start Menu
|
|
CSIDL_DESKTOPDIRECTORY = &H10& ' ..\WinNT\profiles\username\Desktop
|
|
CSIDL_DRIVES = &H11& ' No Path
|
|
CSIDL_NETWORK = &H12& ' No Path
|
|
CSIDL_NETHOOD = &H13& ' ..\WinNT\profiles\username\NetHood
|
|
CSIDL_FONTS = &H14& ' ..\WinNT\fonts
|
|
CSIDL_TEMPLATES = &H15& ' ..\WinNT\ShellNew
|
|
CSIDL_COMMON_STARTMENU = &H16& ' ..\WinNT\profiles\All Users\Start Menu
|
|
CSIDL_COMMON_PROGRAMS = &H17& ' ..\WinNT\profiles\All Users\Start Menu\Programs
|
|
CSIDL_COMMON_STARTUP = &H18& ' ..\WinNT\profiles\All Users\Start Menu\Programs\Startup
|
|
CSIDL_COMMON_DESKTOPDIRECTORY = &H19& '..\WinNT\profiles\All Users\Desktop
|
|
CSIDL_APPDATA = &H1A& ' ..\WinNT\profiles\username\Application Data
|
|
CSIDL_PRINTHOOD = &H1B& ' ..\WinNT\profiles\username\PrintHood
|
|
End Enum
|
|
|
|
Public Enum SHOWCMDFLAGS
|
|
SHOWNORMAL = 5
|
|
SHOWMAXIMIZE = 3
|
|
SHOWMINIMIZE = 7
|
|
End Enum
|
|
|
|
'---------------------------------------------------------------
|
|
Public Function GetSystemFolderPath(ByVal hwnd As Long, ByVal Id As Integer, sfPath As String) As Long
|
|
'---------------------------------------------------------------
|
|
Dim rc As Long ' Return code
|
|
Dim pidl As Long ' ptr to Item ID List
|
|
Dim cbPath As Long ' char count of path
|
|
Dim szPath As String ' String var for path
|
|
'---------------------------------------------------------------
|
|
szPath = Space(MAX_PATH) ' Pre-allocate path string for api call
|
|
|
|
rc = SHGetSpecialFolderLocation(hwnd, Id, pidl) ' Get pidl for Id...
|
|
If (rc = 0) Then ' If success is 0
|
|
#If UNICODE Then
|
|
rc = SHGetPathFromIDList(pidl, StrPtr(szPath)) ' Get Path from Item Id List
|
|
#Else
|
|
rc = SHGetPathFromIDList(pidl, szPath) ' Get Path from Item Id List
|
|
#End If
|
|
If (rc = 1) Then ' If success is 1
|
|
szPath = Trim$(szPath) ' Fix path string
|
|
cbPath = Len(szPath) ' Get length of path
|
|
If (Asc(Right(szPath, 1)) = 0) Then cbPath = cbPath - 1 ' Adjust path length
|
|
If (cbPath > 0) Then sfPath = Left$(szPath, cbPath) ' Adjust path string variable
|
|
GetSystemFolderPath = True ' Return success
|
|
End If
|
|
End If
|
|
'---------------------------------------------------------------
|
|
End Function
|
|
'---------------------------------------------------------------
|
|
|
|
'---------------------------------------------------------------
|
|
Public Function CreateShellLink(LnkFile As String, ExeFile As String, WorkDir As String, _
|
|
ExeArgs As String, IconFile As String, IconIdx As Long, _
|
|
ShowCmd As SHOWCMDFLAGS) As Long
|
|
'---------------------------------------------------------------
|
|
Dim rc As Long
|
|
Dim pidl As Long ' Item id list
|
|
Dim dwReserved As Long ' Reserved flag
|
|
Dim cShellLink As ShellLinkA ' An explorer IShellLinkA(Win 95/Win NT) instance
|
|
Dim cPersistFile As IPersistFile ' An explorer IPersistFile instance
|
|
'---------------------------------------------------------------
|
|
If ((LnkFile = "") Or (ExeFile = "")) Then Exit Function ' Validate min. input requirements.
|
|
|
|
On Error GoTo ErrHandler
|
|
Set cShellLink = New ShellLinkA ' Create new IShellLink interface
|
|
Set cPersistFile = cShellLink ' Implement cShellLink's IPersistFile interface
|
|
|
|
With cShellLink
|
|
.SetPath ExeFile ' set command line exe name & path to new ShortCut.
|
|
|
|
If (WorkDir <> "") Then .SetWorkingDirectory WorkDir ' Set working directory in shortcut
|
|
|
|
If (ExeArgs <> "") Then .SetArguments ExeArgs ' Add arguments to command line
|
|
|
|
' if (LnkDesc <> "") then .SetDescription pszName ' Set shortcut description
|
|
' .SetHotkey wHotKey
|
|
|
|
If (IconFile <> "") Then .SetIconLocation IconFile, IconIdx ' Set shortcut icon location & index
|
|
|
|
.SetDescription "ShellLink Sample" & vbNullChar
|
|
' .SetIDList pidl
|
|
' dwReserved = 0
|
|
' .SetRelativePath pszPathRel, dwReserved
|
|
|
|
.SetShowCmd ShowCmd ' Set shortcut's startup mode (min,max,normal)
|
|
End With
|
|
|
|
cShellLink.Resolve 0, SLR_UPDATE
|
|
cPersistFile.Save StrConv(LnkFile, vbUnicode), 0 ' Unicode conversion hack... This must be done!
|
|
CreateShellLink = True ' Return Success
|
|
|
|
'---------------------------------------------------------------
|
|
ErrHandler:
|
|
'---------------------------------------------------------------
|
|
Set cPersistFile = Nothing ' Destroy Object
|
|
Set cShellLink = Nothing ' Destroy Object
|
|
'---------------------------------------------------------------
|
|
End Function
|
|
'---------------------------------------------------------------
|
|
|
|
'---------------------------------------------------------------
|
|
Public Function GetShellLinkInfo(LnkFile As String, ExeFile As String, WorkDir As String, _
|
|
ExeArgs As String, IconFile As String, IconIdx As Long, _
|
|
ShowCmd As Long) As Long
|
|
'---------------------------------------------------------------
|
|
Dim pidl As Long ' Item id list
|
|
Dim wHotKey As Long ' Hotkey to shortcut...
|
|
Dim fd As WIN32_FIND_DATA
|
|
Dim Description As String
|
|
Dim buffLen As Long
|
|
Dim cShellLink As ShellLinkA ' An explorer IShellLink instance
|
|
Dim cPersistFile As IPersistFile ' An explorer IPersistFile instance
|
|
'---------------------------------------------------------------
|
|
If (LnkFile = "") Then Exit Function ' Validate min. input requirements.
|
|
|
|
Set cShellLink = New ShellLinkA ' Create new IShellLink interface
|
|
Set cPersistFile = cShellLink ' Implement cShellLink's IPersistFile interface
|
|
|
|
' Load Shortcut file...(must do this UNICODE hack!)
|
|
On Error GoTo ErrHandler
|
|
cPersistFile.Load StrConv(LnkFile, vbUnicode), STGM_DIRECT
|
|
|
|
With cShellLink
|
|
' Get command line exe name & path of shortcut
|
|
ExeFile = Space(MAX_PATH)
|
|
buffLen = Len(ExeFile)
|
|
.GetPath ExeFile, buffLen, fd, SLGP_UNCPRIORITY
|
|
Dim s As String
|
|
s = fd.cFileName ' Not returned to calling function
|
|
|
|
' Get working directory of shortcut
|
|
WorkDir = Space(MAX_PATH)
|
|
buffLen = Len(WorkDir)
|
|
.GetWorkingDirectory WorkDir, buffLen
|
|
|
|
' Get command line arguments of shortcut
|
|
ExeArgs = Space(MAX_PATH)
|
|
buffLen = Len(ExeArgs)
|
|
.GetArguments ExeArgs, buffLen
|
|
|
|
' Get description of shortcut
|
|
Description = Space(MAX_PATH)
|
|
buffLen = Len(Description)
|
|
.GetDescription Description, buffLen ' Not returned to calling function
|
|
|
|
' Get the HotKey for shortcut
|
|
.GetHotkey wHotKey ' Not returned to calling function
|
|
|
|
' Get shortcut icon location & index
|
|
IconFile = Space(MAX_PATH)
|
|
buffLen = Len(IconFile)
|
|
.GetIconLocation IconFile, buffLen, IconIdx
|
|
|
|
' Get Item ID List...
|
|
.GetIDList pidl ' Not returned to calling function
|
|
|
|
' Set shortcut's startup mode (min,max,normal)
|
|
.GetShowCmd ShowCmd
|
|
End With
|
|
|
|
GetShellLinkInfo = True ' Return Success
|
|
'---------------------------------------------------------------
|
|
ErrHandler:
|
|
'---------------------------------------------------------------
|
|
Set cPersistFile = Nothing ' Destroy Object
|
|
Set cShellLink = Nothing ' Destroy Object
|
|
'---------------------------------------------------------------
|
|
End Function
|
|
'---------------------------------------------------------------
|