1,065
社区成员
发帖
与我相关
我的任务
分享求助高手，VB写快捷方式不完整，不能加入自定义图标，不能加入运行参数以及简介
从网上找到一些代码，我改成一个类，功能是创建快捷方式用，不依赖其它组件，直接二进制写文件，但现在问题是，无法自定义图标，无法加入运行参数，也加不了简介，只能创建一个普能的快捷方式！~
函数代码如下
这是关于快捷方式的资料
http://blog.csdn.net/liuyukuan/article/details/5990753
请高手帮忙完善一下，谢谢！~
函数代码如下
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
请高手帮忙完善一下，谢谢！~
...全文
请发表友善的回复…
发表回复
