VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)

VB爱好者乐园(VBGood)

 找回密码
 立即注册
搜索
楼主: icecept

用api建立快捷方式<VB6.0>桌面、启动项、开始菜单

[复制链接]
 楼主| 发表于 2007-12-27 19:33:06 | 显示全部楼层
用windows script host 建立快捷方式的例子请参照:
http://www.vbgood.com/viewthread.php?tid=59332
附件: Windows Script Host.rar
回复 支持 反对

使用道具 举报

发表于 2007-12-28 23:27:18 | 显示全部楼层
我的没有"vb6stkit.DLL",楼主能上传给我吗?
回复 支持 反对

使用道具 举报

 楼主| 发表于 2007-12-29 12:37:33 | 显示全部楼层

VB6STKIT.dll

VB6STKIT.dll.rar

45.9 KB, 下载次数: 155

回复 支持 反对

使用道具 举报

发表于 2007-12-29 17:37:37 | 显示全部楼层
多谢了!!
回复 支持 反对

使用道具 举报

jackyang 该用户已被删除
发表于 2008-1-31 14:04:31 | 显示全部楼层
提示: 作者被禁止或删除 内容自动屏蔽
回复 支持 反对

使用道具 举报

发表于 2008-1-31 16:32:30 | 显示全部楼层
路过........
回复 支持 反对

使用道具 举报

 楼主| 发表于 2008-2-1 17:18:17 | 显示全部楼层

最新修改版

'创建快捷方式的API函数
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  文件夹的名称 “$(proprams)” 代表程序文件夹  "."代表当前目录" ".."代表上一级目录"

'lpstrLinkName 快捷键的名称
'
'lpstrLinkPath 快捷键的路径
'
'lpstrLinkArgs       命令行参数,  一般用""
'例:c:\windows\开门光驱.exe /opendoor 这个/opendoor就是lptrLinkArgs
'
'fPrivate True
'
'sParent 上一层文件夹

'快捷方式中的常数
Public Enum ShortCutPosition
       vbDesktop = 1      '桌面
       vbStart = 2        '启动项
       vbStartMenu = 3    '开始菜单程序项
       vbGroup = 4        '开始菜单顶端
End Enum

'创建快捷方式
'此shortcut的调用方法:ShortCut 快捷方式所方的位置,"快捷方式的名称","快捷方式所指应用程序的路径"
Private Sub ShortCut(Position As ShortCutPosition, LinkName As String, Path As String)
     Dim ret As Long
     Select Case Position
           Case 1
                ret = fCreateShellLink("..\\..\\桌面", LinkName, Path, "", True, "$(Programs)")
                If ret = 0 Then
                   ret = fCreateShellLink("..\\..\\Desktop", LinkName, Path, "", True, "$(Programs)")
                End If
           Case 2
                '此处的"启动"是程序文件夹中的启动文件夹
                ret = fCreateShellLink("启动", LinkName, Path, "", True, "$(Programs)")
           Case 3
                '在开始菜单程序文件夹建立快捷方式,
                ret = fCreateShellLink(".", LinkName, Path, "", True, "$(Programs)")
           Case 4
                '在开始菜单文件夹建立快捷方式,与程序文件夹在同一目录
                ret = fCreateShellLink("..", LinkName, Path, "", True, "$(Programs)")
    End Select
End Sub

Private Sub Command1_Click()
    ShortCut vbDesktop, "计算器", "C:\WINDOWS\system32\calc.exe"
End Sub

Private Sub Command2_Click()
    ShortCut vbStart, "计算器", "C:\WINDOWS\system32\calc.exe"
End Sub

Private Sub Command3_Click()
    ShortCut vbStartMenu, "计算器", "C:\WINDOWS\system32\calc.exe"
End Sub

Private Sub Command4_Click()
    ShortCut vbGroup, "计算器", "C:\WINDOWS\system32\calc.exe"
End Sub
回复 支持 反对

使用道具 举报

 楼主| 发表于 2008-4-21 15:01:58 | 显示全部楼层
给大家提个见议,那就是把VB6STKIT.dll放置在vb的资源文件里,当系统没有此文件时,就把它释放到系统目录,并注册。
回复 支持 反对

使用道具 举报

 楼主| 发表于 2008-4-21 15:03:50 | 显示全部楼层
用资源文件做捆绑工具,(OCX加入资源文件)

具体内容看附件源程序,


附件: 控件加入资源文件.rar
回复 支持 反对

使用道具 举报

发表于 2008-4-21 15:33:23 | 显示全部楼层
刚好看到一个不api建立的:

不用VB6STKIT.DLL建立快捷方式2008年01月05日 星期六 上午 09:52做一个类模块,提供一个函数:CreateGroup,可以建立快捷方式的,用法很简单

Option Explicit
'******************不用VB6STKIT.DLL建立快捷方式*********************
'文件:clsShellLink.cls
'描叙:不用VB6STKIT.DLL建立快捷方式
'用法:obj.CreateGroup 路径,exe文件名(可以加参数),快捷方式的显示名称,文件组(可选,空的话不建立)
'    例如 :
'    Private Sub Form_Load()
'       Dim Shelllin As New clsShellLink
'       Shelllin.Bind Label1 '使用前必须的,绑定一个lable控件(先在窗体里放一个撒)
'       Shelllin.CreateGroup 桌面, App.Path & "\" & App.EXEName & ".exe", "哈哈1" '在桌面上天加自己的快捷方式
'       Set Shelllin = Nothing
'    End Sub
'*****************欢迎访问水木空间http://hi.baidu.com/xiejienet*****


Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" (pidl As Long, ByVal pszPath As String) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Const MAX_PATH = 255
Private DDEObj As Object

Public Enum SpecialFolder
        桌面 = &H0
        所有用户桌面 = &H19
        程序 = &H2
        所有用户程序 = &H17
        启动 = &H7
        所有用户启动 = &H18
End Enum

'获取特殊目录
Private Function GetShellFolderPath(ByVal spFolder As SpecialFolder) As String
    Dim pID As Long, sTmp As String
    If SHGetSpecialFolderLocation(0&, spFolder, pID) = 0& Then
        sTmp = String(MAX_PATH + 2, 0)
        If SHGetPathFromIDList(ByVal pID, sTmp) <> 0& Then GetShellFolderPath = Left(sTmp, InStr(1, sTmp, vbNullChar) - 1)
    End If
    If pID <> 0& Then GlobalFree pID
End Function


'创建快捷方式,
'用法:
'CreateGroup 路径,exe文件名(可以加参数),快捷方式的显示名称,文件组(可选,空的话不建立)
Function CreateGroup(ByVal spShellLinkPath As SpecialFolder, ByVal strCmdLine As String, ByVal strDisplayName As String, Optional strGroupName As String = "") As Boolean
   Dim i As Integer
   Dim Sourcefile As String, Destinationfile As String, ProgPath As String, DeskPath As String
On Error Resume Next

   ProgPath = GetShellFolderPath(spShellLinkPath)
   If ProgPath = "" Then Exit Function '路径获取失败
   Sourcefile = GetShellFolderPath(所有用户程序) & "\" & strDisplayName & ".lnk"
   
'   DDEObj.LinkMode = 0
   For i = 1 To 20
      DDEObj.LinkTopic = "Progman|Progman" '设置发送端应用程序和主题
      If Err = 0 Then Exit For
      DoEvents
   Next

   DDEObj.LinkMode = 2 '采用手动方式建立连接
   For i = 1 To 10
      DoEvents
   Next
   
   DDEObj.LinkTimeout = 100 '设置等待 DDE 响应消息的时间。
   DDEObj.LinkExecute "[AddItem(" & Chr(34) & strCmdLine & Chr(34) & "," & strDisplayName & ")]" '建立一个快捷方式
   If Dir(Sourcefile) = "" Then Exit Function '快捷方式没建立成功
   
   If strGroupName = "" Then '建立程序组?
        Destinationfile = ProgPath & "\" & strDisplayName & ".lnk"
   Else
        MkDir ProgPath & "\" & strGroupName
        Destinationfile = ProgPath & "\" & strGroupName & "\" & strDisplayName & ".lnk"
   End If
      
   If LCase(Sourcefile) <> LCase(Destinationfile) Then
        FileCopy Sourcefile, Destinationfile '复制到程序组
        Kill Sourcefile
   End If

   '断开DDE联接
   DDEObj.LinkMode = 0
   DDEObj.LinkTopic = ""
   CreateGroup = True
End Function
Public Sub Bind(Obj As Object)
Set DDEObj = Obj
End Sub

Private Sub Class_Initialize()
Set DDEObj = Nothing
End Sub
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

文字版|手机版|小黑屋|VBGood  

GMT+8, 2019-12-9 03:52

VB爱好者乐园(VBGood)
快速回复 返回顶部 返回列表