一个建立快捷方式的类，定位不到参数位置，求助
程序代码：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以上为部份代码
完整模块代码
Module1.rar
(5.78 KB)
参考了LNK文件格式介绍，http://www.
我能读出来快捷方式的信息，创建一个新的快捷方式的话，参数加不上去，自定义图标没有，仅仅能够使用
创建出来的快捷方式是这样的，起始位置没有，运行方式没有，备注加不上去
[local]1[/local]
有请高手指点一二！~谢谢！~
