|
本帖最后由 joforn 于 2012-7-27 19:28 编辑
下面的这个过程是一个通用的,可以自己识别你输入的路径名是一个文件还是一个目录。
运行Test后可以自己对比一下在桌面上生的那四个快捷方式的不同之处。
- Option Explicit
- Private Declare Function PathFileExistsW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
- Private Declare Function PathIsDirectoryW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
- Private Declare Function PathRenameExtensionW Lib "shlwapi.dll" (ByVal pszPathas As Long, ByVal pszExt As Long) As Long
- Public Sub mShellLnk(ByVal LnkName As String, ByVal FilePath As String, Optional ByVal StrArg As String, Optional ByVal IconFileIconIndex As String = vbNullString, Optional ByVal HookKey As String = "", Optional ByVal StrRemark As String = "")
- '调用说明:
- '
- 'LnkName = 快捷方式文件名,如果无路径则自动新建到桌面;无后缀名(.lnk)会自动补齐.
- 'FilePath = 目标文件名,全路径.
- 'StrArg = 参数,可选.
- 'IconFileIconIndex = 图标所在库及索引,由逗号分隔,可选.如: "c:\windows\system32\notepad.exe,0"
- 'HookKey = 热键,值未知,可选.
- 'StrRemark = 备注,可选.
- '
- Dim WshShell As Object, oShellLink As Object, strDeskTOP As String
-
- On Error Resume Next
-
- Set WshShell = CreateObject("Wscript.shell")
-
- If WshShell Is Nothing Then Exit Sub
-
- strDeskTOP = WshShell.SpecialFolders("Desktop") '桌面路径
-
- LnkName = PathRenameExtension(LnkName, "LNK")
-
- If InStr(1, LnkName, "", vbTextCompare) = 0 Then '如果不包含全路径,则在桌面创建快捷方式
- Set oShellLink = WshShell.CreateShortcut(strDeskTOP & "" & LnkName)
- Else '否则在指定位置创建
- Set oShellLink = WshShell.CreateShortcut(LnkName)
- End If
-
- oShellLink.TargetPath = FilePath
-
- oShellLink.Arguments = StrArg
- oShellLink.WindowStyle = 1 '风格
- oShellLink.Hotkey = HookKey '热键
-
- If FileExists(FilePath) Then
- If IconFileIconIndex = vbNullString Then '图标
- oShellLink.IconLocation = FilePath & ",0" '默认使用目标文件图标
- Else
- oShellLink.IconLocation = IconFileIconIndex
- End If
- oShellLink.WorkingDirectory = Mid(FilePath, 1, InStrRev(FilePath, "")) '源文件所在目录
- End If
-
- oShellLink.Description = StrRemark '快捷方式备注内容
-
- oShellLink.Save '保存创建的快捷方式
-
- Set WshShell = Nothing
- Set oShellLink = Nothing
- End Sub
- '检测文件是否存在
- Private Function FileExists(ByVal Path As String) As Boolean
- Path = Path & vbNullChar
- If PathFileExistsW(StrPtr(Path)) Then
- FileExists = PathIsDirectoryW(StrPtr(Path)) = 0
- End If
- End Function
- '修改路径中的后缀名,后缀名为空时将去掉后缀。
- Private Function PathRenameExtension(ByVal Path As String, ByVal Extension As String) As String
- Dim I As Long
-
- Path = Path & String(260, vbNullChar)
- If Len(Extension) Then
- Extension = IIf(Mid$(Extension, 1, 1) = ".", vbNullString, ".") & Extension & vbNullChar
- Else
- Extension = vbNullChar
- End If
- PathRenameExtensionW StrPtr(Path), StrPtr(Extension)
- I = InStr(Path, vbNullChar) - 1
- If I < 0 Then I = Len(Path)
- PathRenameExtension = Mid$(Path, 1, I)
- End Function
- '这个是演示的调用
- Sub Test()
- mShellLnk "C盘", "C:"
- mShellLnk "系统目录", "C:\Windows"
- mShellLnk "BOOT配置", "C:\BOOT.INI"
- mShellLnk "Explorer", "C:\Windows\Explorer.exe", , "C:\Windows\Explorer.exe,1"
- End Sub
复制代码 |
评分
-
1
查看全部评分
-
|