'创建快捷方式，兼容vista '要把vb6stkit.DLL放到程序目录 '敖士伟 09-10-27 '只对“桌面”和“开启”有效，其它还没做 '=========开启外部同步程序定义开始 Const SYNCHRONIZE = &H100000 Const INFINITE = &HFFFF 'Wait forever Const WAIT_OBJECT_0 = 0 'The state of the specified object is signaled. Const WAIT_TIMEOUT = &H102 'The time-out interval elapsed,and the Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long,ByVal bInheritHandle As Long,ByVal dwProcessId As Long) As Long Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long,ByVal dwMilliseconds As Long) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long '=========开启外部同步程序定义结束 '创建快捷方式 Private Declare Function fCreateShellLink Lib "vb6stkit.DLL" ( _ ByVal lpstrFolderName As String,_ ByVal lpstrLinkName As String,_ ByVal lpstrLinkPath As String,_ ByVal lpstrLinkArgs As String,_ ByVal fPrivate As Long,_ ByVal sParent As String) As Long ' 'lpstrFolderName <a href="/tag/wenjian/" target="_blank" class="keywords">文件</a>夹的<a href="/tag/mingcheng/" target="_blank" class="keywords">名称</a> “$(proprams)” 程序组 "$(Strar Menu)" 开始<a href="/tag/caidan/" target="_blank" class="keywords">菜单</a> 'lpstrLinkName 快捷键的<a href="/tag/mingcheng/" target="_blank" class="keywords">名称</a> ' 'lpstrLinkPath 快捷键的路径 ' 'lpstrLinkArgs 这里是命令行参数 ' 'fPrivate True ' 'sParent 上一层<a href="/tag/wenjian/" target="_blank" class="keywords">文件</a>夹 '快捷方式中的常数 Public Enum ShortCutPosition vbDesktop = 1 '桌面 vbStart = 2 '启动项 vbStartMenu = 3 '开始<a href="/tag/caidan/" target="_blank" class="keywords">菜单</a>程序项 vbGroup = 4 '开始<a href="/tag/caidan/" target="_blank" class="keywords">菜单</a>顶端 End Enum '开启外部同步程序过程 Private Sub cmdShell(s_cmd As String) Dim lPid As Long Dim lHnd As Long Dim lRet As Long lPid = Shell(s_cmd,vbNormalFocus) If lPid <> 0 Then lHnd = OpenProcess(SYNCHRONIZE,lPid) 'Get a handle to the shelled process. If lHnd <> 0 Then 'If successful,wait for the lRet = WaitForSingleObject(lHnd,INFINITE) ' application to end. CloseHandle (lHnd) 'Close the handle. End If 'Unload Me End If End Sub '创建快捷方式 Public Sub ShortCut(Position As ShortCutPosition,LinkName As String,Path As String,group As String) 'vista If Dir(GetSysDrv & "/Users/" & GetUser & "/AppData/Roaming/Microsoft/Windows/Start Menu/Programs/") <> "" Then Dim ret As Long Select Case Position Case 1 ret = fCreateShellLink("..//..//桌面",LinkName,Path,"",True,"$(Programs)") If ret = 0 Then ret = fCreateShellLink("..//..//Desktop","$(Programs)") End If If ret = 0 Then ret = fCreateShellLink(".","$(Programs)") cmdShell "cmd /c copy """ & GetSysDrv & "/Users/" & GetUser & "/AppData/Roaming/Microsoft/Windows/Start Menu/Programs/" & LinkName & ".lnk"" " & GetSysDrv & "//Users//" & GetUser & "//Desktop//" End If Case 2 ret = fCreateShellLink("启动","$(Programs)") Case 3 '在开始<a href="/tag/caidan/" target="_blank" class="keywords">菜单</a>程序项建立快捷方式 Dim strat_Path As String strat_Path = GetSysDrv & "/Users/" & GetUser & "/AppData/Roaming/Microsoft/Windows/Start Menu/Programs/" & group If Dir(strat_Path) = "" Then cmdShell "cmd /c mkdir """ & strat_Path & """" End If ret = fCreateShellLink(".","$(Programs)") cmdShell "cmd /c move """ & GetSysDrv & "/Users/" & GetUser & "/AppData/Roaming/Microsoft/Windows/Start Menu/Programs/" & LinkName & ".lnk"" """ & GetSysDrv & "/Users/" & GetUser & "/AppData/Roaming/Microsoft/Windows/Start Menu/Programs/" & group & """" Case 4 '在开始<a href="/tag/caidan/" target="_blank" class="keywords">菜单</a>顶端建立快捷方式 ret = fCreateShellLink("..","$(Programs)") End Select Else Dim retxp As Long Select Case Position Case 1 retxp = fCreateShellLink("..//..//桌面","$(Programs)") If retxp = 0 Then retxp = fCreateShellLink("..//..//Desktop","$(Programs)") End If Case 2 retxp = fCreateShellLink("启动","$(Programs)") Case 3 '在开始<a href="/tag/caidan/" target="_blank" class="keywords">菜单</a>程序项建立快捷方式 Dim strat_Pathxp As String strat_Pathxp = GetSysDrv & "/Documents and Settings/" & GetUser & "/「开始」<a href="/tag/caidan/" target="_blank" class="keywords">菜单</a>/程序/" & group If Dir(strat_Pathxp) = "" Then cmdShell "cmd /c mkdir """ & strat_Pathxp & """" End If retxp = fCreateShellLink(".","$(Programs)") cmdShell "cmd /c move """ & GetSysDrv & "/Documents and Settings/" & GetUser & "/「开始」<a href="/tag/caidan/" target="_blank" class="keywords">菜单</a>/程序/" & LinkName & ".lnk"" """ & GetSysDrv & "/Documents and Settings/" & GetUser & "/「开始」<a href="/tag/caidan/" target="_blank" class="keywords">菜单</a>/程序/" & group & """" Case 4 '在开始<a href="/tag/caidan/" target="_blank" class="keywords">菜单</a>顶端建立快捷方式 retxp = fCreateShellLink("..","$(Programs)") End Select End If End Sub Public Sub DelShortCut(Position As ShortCutPosition,group As String) 'vista If Dir(GetSysDrv & "/Users/" & GetUser & "/AppData/Roaming/Microsoft/Windows/Start Menu/Programs/") <> "" Then Dim ret As Long Select Case Position Case 1 cmdShell "cmd /c DEL """ & GetSysDrv & "/Users/" & GetUser & "/Desktop/" & LinkName & ".lnk""" Case 2 'ret = fCreateShellLink("启动","$(Programs)") Case 3 cmdShell "cmd /c rd /s /q """ & GetSysDrv & "/Users/" & GetUser & "/AppData/Roaming/Microsoft/Windows/Start Menu/Programs/" & group & """" Case 4 '在开始<a href="/tag/caidan/" target="_blank" class="keywords">菜单</a>顶端建立快捷方式 'ret = fCreateShellLink("..","$(Programs)") End Select Else Dim retxp As Long Select Case Position Case 1 cmdShell "cmd /c DEL """ & GetSysDrv & "/Documents and Settings/" & GetUser & "/Desktop/" & LinkName & ".lnk""" cmdShell "cmd /c DEL """ & GetSysDrv & "/Documents and Settings/" & GetUser & "/桌面/" & LinkName & ".lnk""" Case 2 ' retxp = fCreateShellLink("启动","$(Programs)") Case 3 cmdShell "cmd /c rd /s /q """ & GetSysDrv & "/Documents and Settings/" & GetUser & "/「开始」<a href="/tag/caidan/" target="_blank" class="keywords">菜单</a>/程序/" & group & """" Case 4 '在开始<a href="/tag/caidan/" target="_blank" class="keywords">菜单</a>顶端建立快捷方式 ' retxp = fCreateShellLink("..","$(Programs)") End Select End If End Sub

调用方式：
Private Sub Command1_Click()
ShortCut vbDesktop,"意达进销存管理系统","http://localhost/app","意达"
ShortCut vbStartMenu,"意达进销存管理系统1","http://localhost/app1","意达"
Me.Show
MsgBox "ok"
End Sub

Private Sub Command2_Click()

DelShortCut vbDesktop,"意达"DelShortCut vbStartMenu,"意达"End Sub