Private Sub Command1_Click()
Text1 = ReadShortCut("d:/我的快捷方式.lnk")
End Sub
Function ReadShortCut(ByVal strFile As String) As String
If Len(Dir(strFile)) = 0 Or Right(strFile, 4) <> ".lnk" Then Exit Function
ReadShortCut = CreateObject("WScript.Shell").CreateShortcut(strFile).TargetPath
End Function
VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 3090
ClientLeft = 60
ClientTop = 450
ClientWidth = 4680
LinkTopic = "Form1"
ScaleHeight = 3090
ScaleWidth = 4680
StartUpPosition = 3 '窗口缺省
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
'///////////快捷方式文件格式部分结构/////////////
'//文件头段
Private Type LNKHEAD
dwSize As Long '结构长度
dwGUID(1 To 4) As Long '快捷方式GUID
dwFlags As Long
dwFileAttributes As Long '文件属性
dwCreationTime As FILETIME '创建时间
dwModificationTime As FILETIME '修改时间
dwLastaccessTime As FILETIME '最后访问时间
dwFileLen As Long '指向的文件长度
dwIconIndex As Long '自定义图标引索
dwWinStyle As Long '目标文件执行时窗口显示方式：1 ? 正常显示 2 ? 最小化 3 ? 最大化
dwHotkey As Long '热键
dwReserved1 As Long
dwReserved2 As Long
End Type
'//文件位置信息段
Private 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
'//本地卷信息表段
Private Type LOCALVOLUMETAB
dwSize As Long
dwTypeOfVolume As Long
'卷类型:
'0 Unknown
'1 No root directory
'2 Removable (Floppy, Zip, etc..)
'3 Fixed (Hard disk)
'4 Remote (Network drive)
'5 CD -ROM
'6 Ram drive (Shortcuts to stuff on a ram drive, now that''s smart...)
dwVolumeSerialNumber As Long '标识卷序列号
dwOffsetOfVolumeName As Long '卷名称的偏移
'char strVolumeName[0];//这个是可变长度因此为 0,不包含在这个结构里
End Type
'//网络卷信息表段
Private Type NETWORKVOLUMETAB
dwSize As Long
dwUnknown1 As Long
dwOffsetOfNetShareName As Long
dwUnknown2 As Long
dwUnknown3 As Long
'char strNetShareName[0];//这个是可变长度因此设为0,不包含在这个结构里
End Type
'本文来自LIONKING1990博客，转载请标明出处：
'http://hi.baidu.com/lionking1990
'文件时间
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Private Declare Function SystemTimeToFileTime Lib "kernel32" (lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME) As Long
Private Declare Function LocalFileTimeToFileTime Lib "kernel32" (lpLocalFileTime As FILETIME, lpFileTime As FILETIME) As Long
Private Type LnkInfo
'Flags
fgSIIL As Boolean '有shell item id list
fgToFile As Boolean '指向文件或文件夹
fgDescript As Boolean '存在描述字符串
fgRelativePath As Boolean '存在相对路径
fgWorkPath As Boolean '存在工作路径
fgHaveCommand As Boolean '存在命令行参数
fgCustomIcon As Boolean '存在自定义图标
'FileAttr快捷方式所指目标文件的属性
faReadOnly As Boolean '只读
faHide As Boolean '隐藏
faSystem As Boolean '系统文件
faVolumeLabel As Boolean '卷标
faFolder As Boolean '文件夹
faChanged As Boolean '上次存档后被改变过
faEncrypted As Boolean '被加密
faNomal As Boolean '属性为一般
faTemporary As Boolean '临时
faSparseFile As Boolean '稀疏文件（sparse file）
faReparsePoint As Boolean '重分析点数据（reparse point）
faCompression As Boolean '被压缩
faWeaned As Boolean '脱机
'目标文件时间
ftCreateTime As Date
ftModificateTime As Date
ftLastaccessTime As Date
'详细
fgIconIndex As Long
StrShellItemIdList As String
StrLocalVolumeLabel As String
StrLocalPath As String
StrNetWorkVolumeLabel As String
StrNetWorkPath As String
StrRemainPath As String
StrDescript As String
StrRelativePath As String
StrWorkPath As String
StrCommandLine As String
StrIconFileName As String
End Type
Private Type SHITEMID
cb As Long
abID() As Byte
End Type
Private Type ITEMIDLIST
mkid As SHITEMID
End Type
Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" Alias "SHGetPathFromIDListA" (ByVal pIDL As Long, ByVal szPath As String) As Long
Private Declare Function SHGetIDListFromPath Lib "SHELL32.DLL " Alias "#162" (ByVal szPath As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetFileTime Lib "kernel32" (ByVal hFile As Long, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Const OPEN_EXISTING = 3
Private Const FILE_SHARE_READ = &H1
Private Const GENERIC_READ = &H80000000
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Function ReadLink(ByVal StrLinkPath As String) As String
Dim Lnk 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
FileNum = FreeFile()
Lnk = StrLinkPath
Open Lnk For Binary As #FileNum
'文件头
fSeek = &H1
Get #FileNum, fSeek, LFH
If CheckIsLink(LFH) = False Then MsgBox "不是快捷方式": Exit Function
With LI
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
Get #FileNum, fSeek, iBuf
fSeek = fSeek + &H2
ReDim IDL.abID(iBuf - 1)
IDL.cb = VarPtr(IDL.abID(0))
Get #FileNum, fSeek, IDL.abID
LI.StrShellItemIdList = GetPathFormItemIdList(IDL.cb)
fSeek = fSeek + iBuf
End If
'指向文件
If .fgToFile Then
Get #FileNum, fSeek, FLI
With FLI
LvtSeek = fSeek + .dwOffsetOfVolume
NvtSeek = fSeek + .dwOffsetOfNetworkVolume
RemainSeek = fSeek + .dwOffsetOfRemainingPath
'有本地卷
If .dwFlags And &H1 Then
Get #FileNum, LvtSeek, LVT
With LVT
'dwVolumeSerialNumber即盘符序列号
Debug.Assert .dwVolumeSerialNumber Or GetSerialNumber("c:\") ', .dwTypeOfVolume, .dwOffsetOfVolumeName
VolumeLableSeek = LvtSeek + .dwOffsetOfVolumeName
iBuf = -1
ReDim Buf(255)
Do
iBuf = iBuf + 1
Get #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
Get #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
End If
'有网络卷
If .dwFlags And &H2 Then
Get #FileNum, NvtSeek, NVT
With NVT
Debug.Assert .dwSize
VolumeLableSeek = NvtSeek + .dwOffsetOfNetShareName
iBuf = -1
ReDim Buf(255)
Do
iBuf = iBuf + 1
Get #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
Get #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
End If
If RemainSeek <> 0 Then
iBuf = -1
ReDim Buf(255)
Do
iBuf = iBuf + 1
Get #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
End With
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)
End If
If .fgCustomIcon Then
LI.StrIconFileName = GetUnicodeStr(fSeek, FileNum)
End If
'后面是附加数据节
Get #FileNum, fSeek, ExtraStuffLen
fSeek = fSeek + 4
If ExtraStuffLen <> 0 Then
End If
End With
Close
With LI
'Flags
Debug.Print .fgSIIL '有shell item id list
Debug.Print .fgToFile '指向文件或文件夹
'ReadLink = .fgToFile
Debug.Print .fgDescript '存在描述字符串
Debug.Print .fgRelativePath '存在相对路径
Debug.Print .fgWorkPath '存在工作路径
'ReadLink = .fgWorkPath
Debug.Print .fgHaveCommand '存在命令行参数
Debug.Print .fgCustomIcon '存在自定义图标
'FileAttr快捷方式所指目标文件的属性
Debug.Print .faReadOnly '只读
Debug.Print .faHide '隐藏
Debug.Print .faSystem '系统文件
Debug.Print .faVolumeLabel '卷标
Debug.Print .faFolder '文件夹
Debug.Print .faChanged '上次存档后被改变过
Debug.Print .faEncrypted '被加密
Debug.Print .faNomal '属性为一般
Debug.Print .faTemporary '临时
Debug.Print .faSparseFile '稀疏文件（sparse file）
Debug.Print .faReparsePoint '重分析点数据（reparse point）
Debug.Print .faCompression '被压缩
Debug.Print .faWeaned '脱机
'目标文件时间
Debug.Print .ftCreateTime
Debug.Print .ftModificateTime
Debug.Print .ftLastaccessTime
'详细
Debug.Print .StrShellItemIdList
Debug.Print .StrLocalVolumeLabel
Debug.Print .StrLocalPath
ReadLink = .StrLocalPath
Debug.Print .StrNetWorkVolumeLabel
Debug.Print .StrNetWorkPath
Debug.Print .StrRemainPath
Debug.Print .StrDescript
Debug.Print .StrRelativePath
Debug.Print .StrWorkPath
Debug.Print .StrCommandLine
Debug.Print .StrIconFileName
End With
' End
End Function
Private Function GetUnicodeStr(ByRef fSeek As Long, ByVal FileNum As Integer) As String
Dim iBuf As Integer
Dim Buf() As Byte
Get #FileNum, fSeek, iBuf
fSeek = fSeek + 2
If iBuf > 0 Then
iBuf = iBuf * 2
ReDim Buf(1 To iBuf)
Get #FileNum, fSeek, Buf()
fSeek = fSeek + iBuf
GetUnicodeStr = Buf()
End If
End Function
Private Function GetIDListFormPath(ByRef StrPath As String) As Byte()
Dim pID As Long
Dim Buf() As Byte
Dim pRead As Long
Dim cb As Integer
Dim cLen As Long
pID = SHGetIDListFromPath(StrConv(StrPath, vbUnicode))
' Debug.Print GetPathFormItemIdList(pID)
Debug.Assert pID
pRead = pID
Do
CopyMemory cb, ByVal pRead, 2
pRead = pRead + cb
Loop Until cb = 0
cLen = pRead - pID + 2
ReDim Buf(cLen - 1)
CopyMemory Buf(0), ByVal pID, cLen
GetIDListFormPath = Buf
' Dim IDL As SHITEMID
' ReDim IDL.abID(cLen - 1)
' IDL.abID = Buf
' IDL.cb = VarPtr(IDL.abID(0))
'' CopyMemory IDL.abID(0), ByVal pID, cLen
' Debug.Print GetPathFormItemIdList(IDL.cb)
End Function
Private Function GetPathFormItemIdList(ByVal pIDL As Long) As String
Dim StrPath As String * 260
Debug.Assert SHGetPathFromIDList(pIDL, StrPath)
GetPathFormItemIdList = Left$(StrPath, InStr(1, StrPath, Chr$(0)) - 1)
End Function
Private Sub OutL(ByVal FileSeek As Long, ByRef Data As Long, ByVal FileNum As Integer)
FileSeek = FileSeek + 1
Put #FileNum, FileSeek, Data
End Sub
Function GetSerialNumber(sRoot As String, Optional ByRef sVolumeLable As String, Optional ByRef sVolumeType As String) As Long
Dim lSerialNum As Long
Dim strLabel As String, strType As String
strLabel = Space$(256)
strType = Space$(256)
Debug.Assert GetVolumeInformation(sRoot, strLabel, 256&, lSerialNum, 0, 0, strType, 256&)
GetSerialNumber = lSerialNum
sVolumeLable = Left$(strLabel, InStr(1, strLabel, Chr$(0)) - 1)
sVolumeType = Left$(strType, InStr(1, strType, Chr$(0)) - 1)
End Function
Private Sub GetLinkAttr(ByVal gAttr As Long, faReadOnly As Boolean, faHide As Boolean, faSystem As Boolean, faVolumeLabel As Boolean, faFolder As Boolean, faChanged As Boolean, faEncrypted As Boolean, faNomal As Boolean, faTemporary As Boolean, faSparseFile As Boolean, faReparsePoint As Boolean, faCompression As Boolean, faWeaned As Boolean)
faReadOnly = gAttr And &H1
faHide = gAttr And &H2
faSystem = gAttr And &H4
faVolumeLabel = gAttr And &H8
faFolder = gAttr And &H10
faChanged = gAttr And &H20
faEncrypted = gAttr And &H40
faNomal = gAttr And &H80
faTemporary = gAttr And &H100
faSparseFile = gAttr And &H200
faReparsePoint = gAttr And &H400
faCompression = gAttr And &H800
faWeaned = gAttr And &H1000
End Sub
'64位时间转VB时间
Friend Function FileTimeToDate(fTime As FILETIME) As Date
Dim SysTime As SYSTEMTIME
If fTime.dwHighDateTime = 0 And fTime.dwLowDateTime = 0 Then Exit Function
Debug.Assert FileTimeToLocalFileTime(fTime, fTime)
Debug.Assert FileTimeToSystemTime(fTime, SysTime)
With SysTime
FileTimeToDate = DateSerial(.wYear, .wMonth, .wDay) + TimeSerial(.wHour, .wMinute, .wSecond)
End With
End Function
'VB时间转64位时间
Friend Function FileTimeFromDate(FromDate As Date) As FILETIME
Dim fTime As FILETIME
Dim SysTime As SYSTEMTIME
With SysTime
.wYear = Year(FromDate)
.wMonth = Month(FromDate)
.wDay = Day(FromDate)
.wHour = Hour(FromDate)
.wMinute = Minute(FromDate)
.wSecond = Second(FromDate)
End With
Debug.Assert SystemTimeToFileTime(SysTime, fTime)
Debug.Assert LocalFileTimeToFileTime(fTime, FileTimeFromDate)
End Function
'检查是否是LINK文件
Private Function CheckIsLink(ByRef lHead As LNKHEAD) As Boolean
Dim i As Long
Dim Check(1 To 4) As Long
Check(1) = &H21401
Check(3) = &HC0&
Check(4) = &H46000000
If lHead.dwSize <> Len(lHead) Then Exit Function
For i = 1 To 4
If lHead.dwGUID(i) <> Check(i) Then Exit Function
Next i
CheckIsLink = True
End Function
Private Function SetFlags(ByRef SIIL As Boolean, ByRef ToFile As Boolean, ByRef Descript As Boolean, ByRef RelativePath As Boolean, ByRef WorkPath As Boolean, ByRef HaveCommand As Boolean, ByRef CustomIcon As Boolean)
Dim sFlag As Long
If SIIL Then sFlag = sFlag Or 1
If ToFile Then sFlag = sFlag Or 2
If Descript Then sFlag = sFlag Or 4
If RelativePath Then sFlag = sFlag Or 8
If WorkPath Then sFlag = sFlag Or 16
If HaveCommand Then sFlag = sFlag Or 32
If CustomIcon Then sFlag = sFlag Or 64
SetFlags = sFlag
End Function
Private Sub GetFlags(ByVal gFlag As Long, ByRef SIIL As Boolean, ByRef ToFile As Boolean, ByRef Descript As Boolean, ByRef RelativePath As Boolean, ByRef WorkPath As Boolean, ByRef HaveCommand As Boolean, ByRef CustomIcon As Boolean)
'0 有shell item id list
'1 指向文件或文件夹，如果此位为0表示指向其他。
'2 存在描述字符串
'3 存在相对路径
'4 存在工作路径
'5 存在命令行参数
'6 存在自定义图标
SIIL = gFlag And 1
ToFile = gFlag And 2
Descript = gFlag And 4
RelativePath = gFlag And 8
WorkPath = gFlag And 16
HaveCommand = gFlag And 32
CustomIcon = gFlag And 64
End Sub
Private Sub 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
Put #FileNum, fSeek, LFH
With LI
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
' Private 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
Get #FileNum, fSeek, FLI
With FLI
LvtSeek = fSeek + .dwOffsetOfVolume
NvtSeek = fSeek + .dwOffsetOfNetworkVolume
RemainSeek = fSeek + .dwOffsetOfRemainingPath
'有本地卷
If .dwFlags And &H1 Then
Get #FileNum, LvtSeek, LVT
With LVT
'dwVolumeSerialNumber即盘符序列号
Debug.Assert .dwVolumeSerialNumber Or GetSerialNumber("c:\") ', .dwTypeOfVolume, .dwOffsetOfVolumeName
VolumeLableSeek = LvtSeek + .dwOffsetOfVolumeName
iBuf = -1
ReDim Buf(255)
Do
iBuf = iBuf + 1
Get #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
Get #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
End If
Exit Sub
'有网络卷
If .dwFlags And &H2 Then
Get #FileNum, NvtSeek, NVT
With NVT
Debug.Assert .dwSize
VolumeLableSeek = NvtSeek + .dwOffsetOfNetShareName
iBuf = -1
ReDim Buf(255)
Do
iBuf = iBuf + 1
Get #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
Get #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
End If
If RemainSeek <> 0 Then
iBuf = -1
ReDim Buf(255)
Do
iBuf = iBuf + 1
Get #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
End With
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)
End If
If .fgCustomIcon Then
LI.StrIconFileName = GetUnicodeStr(fSeek, FileNum)
End If
'后面是附加数据节
Get #FileNum, fSeek, ExtraStuffLen
fSeek = fSeek + 4
If ExtraStuffLen <> 0 Then
End If
End With
Close #FileNum
SetAttr StrFocusFilePath, Not LFH.dwFileAttributes
Exit Sub
LineErr:
MsgBox Err.Description, vbOKOnly, "错误"
End Sub
Private Sub Form_Load()
MsgBox ReadLink("C:\Documents and Settings\Administrator\桌面\360安全浏览器7.lnk")
‘Call BuitLink(App.Path & "\360安全浏览器7.lnk", "C:\Program Files\Internet Explorer\IEXPLORE.EXE", , "cmd")
End Sub
ABC.rar
(3.81 KB)
2015-08-18 11:39
