程序代码

Private Sub Command1_Click()
    Dim Sh As Object
    Set Sh = CreateObject("Wscript.shell")
    With Sh.CreateShortcut(Sh.SpecialFolders("Desktop") & "\BaiDu.lnk") '获取桌面路径
        .IconLocation = "%windir%\system32\taskmgr.exe,0" '设置快捷方式的图标(这里引用的是任务管理器的图标)
        .TargetPath = "http://www.baidu.com/"             '设置快捷方式的目标路径
        .Hotkey = "ALT+CTRL+C"                            '设置快捷方式热键
        .Save                                             '生成快捷方式
    End With
End Sub
'=============================================方法一=============================================
'=============================================方法二=============================================
'作    者：嗷嗷叫的老马
'代码出处：http://www.newxing.com/Tech/Program/VisualBasic/WScript.Shell_517.html
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
    
    Set WshShell = CreateObject("WScript.Shell")
    
    strDesktop = WshShell.SpecialFolders("Desktop")                          '桌面路径
    
    If UCase(Right(LnkName, 4)) <> ".LNK" Then
        LnkName = LnkName & ".lnk"
    End If
    
    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 IconFileIconIndex = vbNullString Then                                 '图标
        oShellLink.IconLocation = FilePath & ",0"                            '默认使用目标文件图标
    Else
        oShellLink.IconLocation = IconFileIconIndex
    End If
    
    oShellLink.Description = StrRemark                                       '快捷方式备注内容
    oShellLink.WorkingDirectory = Mid(FilePath, 1, InStrRev(FilePath, "\"))  '源文件所在目录
    oShellLink.Save                                                          '保存创建的快捷方式
    
    Set WshShell = Nothing
    Set oShellLink = Nothing
End Sub
Private Sub Command1_Click() '调用方法
    mShellLnk "紫灵幽梦B'log", "http://www.zlym.cc"       '创建网页快捷方式
   'mShellLnk "计算器", Environ("windir") + "\system32\calc.exe"   '创建软件快捷方式
End Sub