求助高手,VB写快捷方式不完整,不能加入自定义图标,不能加入运行参数以及简介

lys001 2015-10-22 02:43:29
从网上找到一些代码,我改成一个类,功能是创建快捷方式用,不依赖其它组件,直接二进制写文件,但现在问题是,无法自定义图标,无法加入运行参数,也加不了简介,只能创建一个普能的快捷方式!~

函数代码如下
 Public Function BuitLink(ByVal StrLinkPath As String, ByVal StrFocusFilePath As String, Optional ByVal StrDescrip As String, Optional ByVal StrCommand As String, Optional ByVal StrIconFile As String, Optional ByVal lIconIndex As Long, Optional ByVal lWindowState As Long, Optional ByVal StrRelativePath As String)

Dim FileNum As Integer
Dim LFH As LNKHEAD
Dim LI As LnkInfo
Dim FLI As FILELOCATIONINFO
Dim LVT As LOCALVOLUMETAB
Dim NVT As NETWORKVOLUMETAB
Dim fSeek As Long
Dim Buf() As Byte
Dim iBuf As Integer
Dim ExtraStuffLen As Long
Dim LvtSeek As Long
Dim NvtSeek As Long
Dim RemainSeek As Long
Dim PathSeek As Long
Dim VolumeLableSeek As Long
Dim IDL As SHITEMID
Dim StrPath As String
Dim StrFile As String
Dim lngHandle As Long '存放文件句柄

On Error Resume Next
Kill StrLinkPath

If Len(Dir(StrFocusFilePath)) = 0 Then
On Error GoTo LineErr
LFH.dwFileAttributes = GetAttr(StrFocusFilePath)
SetAttr StrFocusFilePath, vbNormal
End If


StrFile = Right$(StrFocusFilePath, InStr(1, StrReverse(StrFocusFilePath), "\") - 1)
StrPath = Left$(StrFocusFilePath, Len(StrFocusFilePath) - Len(StrFile))


FileNum = FreeFile()

Open StrLinkPath For Binary As #FileNum
'文件头
fSeek = &H1
With LFH
.dwSize = Len(LFH)
.dwGUID(1) = &H21401
.dwGUID(3) = &HC0&
.dwGUID(4) = &H46000000
.dwFlags = SetFlags(True, CBool(Len(StrFile)), CBool(Len(StrDescrip)), CBool(Len(StrRelativePath)), CBool(Len(StrPath)), CBool(Len(StrCommand)), CBool(Len(StrIconFile)))

lngHandle = CreateFile(StrFocusFilePath, GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0, 0)
Debug.Assert GetFileTime(lngHandle, .dwCreationTime, .dwLastaccessTime, .dwModificationTime)
CloseHandle lngHandle

.dwFileLen = FileLen(StrFocusFilePath)
.dwIconIndex = lIconIndex
.dwWinStyle = lWindowState
' dwHotkey
End With
' MsgBox LFH.dwFlags

Put #FileNum, fSeek, LFH
'Exit Function
With LI
' MsgBox LFH.dwFlags
GetFlags LFH.dwFlags, .fgSIIL, .fgToFile, .fgDescript, .fgRelativePath, .fgWorkPath, .fgHaveCommand, .fgCustomIcon
GetLinkAttr LFH.dwFileAttributes, .faReadOnly, .faHide, .faSystem, .faVolumeLabel, .faFolder, .faChanged, .faEncrypted, .faNomal, .faTemporary, .faSparseFile, .faReparsePoint, .faCompression, .faWeaned
.ftCreateTime = FileTimeToDate(LFH.dwCreationTime)
.ftModificateTime = FileTimeToDate(LFH.dwModificationTime)
.ftLastaccessTime = FileTimeToDate(LFH.dwLastaccessTime)
fSeek = fSeek + &H4C
'shell item id list

If .fgSIIL Then
Buf = GetIDListFormPath(StrFocusFilePath)
iBuf = UBound(Buf) - LBound(Buf) + 1
Put #FileNum, fSeek, iBuf
fSeek = fSeek + &H2
Put #FileNum, fSeek, Buf
fSeek = fSeek + iBuf
End If
'指向文件

If .fgToFile Then
' Public Type FILELOCATIONINFO
' dwSize As Long
' dwSizeOfTpye As Long
' dwFlags As Long
' dwOffsetOfVolume As Long
' dwOffsetOfBasePath As Long
' dwOffsetOfNetworkVolume As Long
' dwOffsetOfRemainingPath As Long
'End Type

With FLI
.dwFlags = &H1

LvtSeek = fSeek + .dwOffsetOfVolume
NvtSeek = fSeek + .dwOffsetOfNetworkVolume
RemainSeek = fSeek + .dwOffsetOfRemainingPath
.dwSize = Len(FLI)
'有本地卷
' MsgBox .dwFlags
If .dwFlags And &H1 Then
' MsgBox VolumeLableSeek
With LVT
'dwVolumeSerialNumber即盘符序列号
Debug.Assert .dwVolumeSerialNumber Or GetSerialNumber("c:\") ', .dwTypeOfVolume, .dwOffsetOfVolumeName
VolumeLableSeek = LvtSeek + .dwOffsetOfVolumeName
MsgBox VolumeLableSeek
iBuf = -1
ReDim Buf(255)
Do
iBuf = iBuf + 1
Put #FileNum, VolumeLableSeek + iBuf, Buf(iBuf)
Loop Until Buf(iBuf) = 0
With LI
.StrLocalVolumeLabel = StrConv(Buf(), vbUnicode): .StrLocalVolumeLabel = Left$(.StrLocalVolumeLabel, InStr(1, .StrLocalVolumeLabel, Chr$(0)) - 1)
End With
End With
PathSeek = VolumeLableSeek + iBuf + 1
iBuf = -1
ReDim Buf(255)
Do
iBuf = iBuf + 1
Put #FileNum, PathSeek + iBuf, Buf(iBuf)
Loop Until Buf(iBuf) = 0
With LI
.StrLocalPath = StrConv(Buf(), vbUnicode): .StrLocalPath = Left$(.StrLocalPath, InStr(1, .StrLocalPath, Chr$(0)) - 1)
End With
Put #FileNum, LvtSeek, LVT
End If

' Exit Function
'有网络卷
If .dwFlags And &H2 Then

With NVT
Debug.Assert .dwSize
VolumeLableSeek = NvtSeek + .dwOffsetOfNetShareName
iBuf = -1
ReDim Buf(255)
Do
iBuf = iBuf + 1
Put #FileNum, VolumeLableSeek + iBuf, Buf(iBuf)
Loop Until Buf(iBuf) = 0
With LI
.StrNetWorkVolumeLabel = StrConv(Buf(), vbUnicode): .StrNetWorkVolumeLabel = Left$(.StrNetWorkVolumeLabel, InStr(1, .StrNetWorkVolumeLabel, Chr$(0)) - 1)
End With
End With
PathSeek = VolumeLableSeek + iBuf + 1
iBuf = -1
ReDim Buf(255)
Do
iBuf = iBuf + 1
Put #FileNum, PathSeek + iBuf, Buf(iBuf)
Loop Until Buf(iBuf) = 0
With LI
.StrNetWorkPath = StrConv(Buf(), vbUnicode): .StrNetWorkPath = Left$(.StrNetWorkPath, InStr(1, .StrNetWorkPath, Chr$(0)) - 1)
End With
Put #FileNum, NvtSeek, NVT
End If
'Exit Function
If RemainSeek <> 0 Then
' MsgBox "XXX"
iBuf = -1
ReDim Buf(255)
Do
iBuf = iBuf + 1
Put #FileNum, RemainSeek + iBuf, Buf(iBuf)
Loop Until Buf(iBuf) = 0

With LI
.StrRemainPath = StrConv(Buf(), vbUnicode): .StrRemainPath = Left$(.StrRemainPath, InStr(1, .StrRemainPath, Chr$(0)) - 1)

End With

End If
fSeek = fSeek + .dwSize
Put #FileNum, RemainSeek + iBuf, Buf(iBuf)

End With
Put #FileNum, fSeek, FLI
End If
If .fgDescript Then
LI.StrDescript = GetUnicodeStr(fSeek, FileNum)

End If
If .fgRelativePath Then
LI.StrRelativePath = GetUnicodeStr(fSeek, FileNum)

End If
If .fgWorkPath Then
LI.StrWorkPath = GetUnicodeStr(fSeek, FileNum)

End If
If .fgHaveCommand Then
LI.StrCommandLine = GetUnicodeStr(fSeek, FileNum)
' Put #FileNum, fSeek, StrConv(Len(StrConv(StrCommand, vbUnicode)), vbUnicode)
'Put #FileNum, fSeek, StrConv(StrCommand, vbUnicode)

End If
If .fgCustomIcon Then
LI.StrIconFileName = GetUnicodeStr(fSeek, FileNum)

End If
'后面是附加数据节


If ExtraStuffLen <> 0 Then
Put #FileNum, fSeek, ExtraStuffLen
fSeek = fSeek + 4
End If


End With
' Put #FileNum, fSeek, &HAA
Close #FileNum

SetAttr StrFocusFilePath, Not LFH.dwFileAttributes

Exit Function
LineErr:
MsgBox Err.Description, vbOKOnly, "错误"
End Function



这是关于快捷方式的资料
http://blog.csdn.net/liuyukuan/article/details/5990753

请高手帮忙完善一下,谢谢!~


...全文
1869 3 打赏 收藏 转发到动态 举报
写回复
用AI写文章
3 条回复
切换为时间正序
请发表友善的回复…
发表回复
舉杯邀明月 2015-10-26
  • 打赏
  • 举报
回复
好吧,学习一下。
笨狗先飞 2015-10-24
  • 打赏
  • 举报
回复
http://wenku.baidu.com/link?url=dKTjmZ1naCOOqu6xL2amUn01iPZPw0WqkF2umuicULkfyDbSdktVlbDiKLueEtXhTCfqbAHG4KtmBEmK2AHn60pS1o5pXLsytWUtPoswe6e
lys001 2015-10-24
  • 打赏
  • 举报
回复
已自行解决!~不麻烦大家了!~

1,066

社区成员

发帖
与我相关
我的任务
社区描述
VB 资源
社区管理员
  • 资源
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧