Option Explicit
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 dwSizeAs Long '结构长度 dwGUID(1 To 4)As Long'快捷方式GUID dwFlagsAs Long dwFileAttributesAs Long'文件属性 dwCreationTime As FILETIME'创建时间 dwModificationTime As FILETIME '修改时间 dwLastaccessTime As FILETIME'最后访问时间 dwFileLenAs Long '指向的文件长度 dwIconIndexAs Long'自定义图标引索 dwWinStyleAs Long'目标文件执行时窗口显示方式:1 ? 正常显示 2 ? 最小化 3 ? 最大化 dwHotkeyAs Long'热键 dwReserved1As Long dwReserved2As Long
End Type
'//文件位置信息段
Private Type FILELOCATIONINFO dwSizeAs Long dwSizeOfTpyeAs Long dwFlagsAs Long dwOffsetOfVolumeAs Long dwOffsetOfBasePathAs Long dwOffsetOfNetworkVolumeAs Long dwOffsetOfRemainingPathAs Long
End Type
'//本地卷信息表段
Private Type LOCALVOLUMETAB dwSizeAs Long dwTypeOfVolumeAs 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...) dwVolumeSerialNumberAs Long'标识卷序列号 dwOffsetOfVolumeNameAs Long'卷名称的偏移 'charstrVolumeName[0];//这个是可变长度因此为0,不包含在这个结构里
End Type
'//网络卷信息表段
Private Type NETWORKVOLUMETAB dwSizeAs Long dwUnknown1As Long dwOffsetOfNetShareNameAs Long dwUnknown2As Long dwUnknown3As Long 'charstrNetShareName[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 StrCommandLineAs String StrIconFileNameAs String
End Type
Private Type SHITEMID cbAs Long abID()As Byte
End Type
Private Type ITEMIDLIST mkidAs 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 SysTimeAs 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 lngHandleAs 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 ' dwSizeAs Long ' dwSizeOfTpyeAs Long ' dwFlagsAs Long ' dwOffsetOfVolumeAs Long ' dwOffsetOfBasePathAs Long ' dwOffsetOfNetworkVolumeAs Long ' dwOffsetOfRemainingPathAs 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