计算机基本都有c、d、e、f、g盘，如果附件都放在计算机所有的盘符目录下，只在“桌面”有一个“测试.exe”的“快捷方式”图标，vb6代码有搜索该图标的路径的代码吗？


[ 本帖最后由 HVB6 于 2015-8-18 11:41 编辑 ]

这可真是完全不懂

可以分析下快捷文件内容，里面含指向的具体位置的（在记事本里就看的到）

vb6代码如何写？

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

您的代码已经试过，不中。是否做成个EXE，上传？谢谢。

VB 纯代码实现读取与创建快捷方式_修改
工程1.vbp
Type=Exe
Form=Form1.frm
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\..\..\WINDOWS\system32\stdole2.tlb#OLE Automation
IconForm="Form1"
Startup="Form1"
Command32=""
Name="工程1"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="新兴网络"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
[MS Transaction Server]
AutoRefresh=1
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Form1.frm

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

收到的鲜花

• HVB6 于 2015-09-27 21:34 送鲜花  2朵   附言：我很赞同