[技术讨论] VBS个别lnk文件不能读取备注的研究

czjt1234

开始菜单中的 Windows Media Player 的快捷方式
win7 C:\ProgramData\Microsoft\Windows\Start Menu\Programs\Windows Media Player.lnk
win10 C:\ProgramData\Microsoft\Windows\Start Menu\Programs\Accessories\Windows Media Player.lnk
win11 C:\ProgramData\Microsoft\Windows\Start Menu\Programs\Accessories\Windows Media Player Legacy.lnk

在使用 WScript.Shell 和 Shell.Application 对象读取其备注时
win7正常，但win10和win11会报错

'读取 Windows Media Player 快捷方式的备注，win10
Set oWshShell = CreateObject("WScript.Shell")
s = "C:\ProgramData\Microsoft\Windows\Start Menu\Programs\Accessories\Windows Media Player.lnk"
Set oWshShortcut = oWshShell.CreateShortcut(s)
MsgBox oWshShortcut.Description
复制代码

'读取 Windows Media Player 快捷方式的备注，win10
Set oShell = CreateObject("Shell.Application")
s = "C:\ProgramData\Microsoft\Windows\Start Menu\Programs\Accessories\Windows Media Player.lnk"
Set oShellLinkObject = oShell.NameSpace(17).ParseName(s).GetLink
MsgBox oShellLinkObject.Description
复制代码

打开该lnk文件的属性，可以看到win10和win11环境下，备注为空
但是一个备注为空的lnk文件，读取备注应该是空字符串""

根据微软的lnk文件的二进制说明
https://learn.microsoft.com/en-us/openspecs/windows_protocols/ms-shllink/16cb4ca1-9339-4d0c-a68d-bf1d6cc0f943
读取 Windows Media Playerr.lnk 快捷方式的备注
结果为 @%systemroot%\syswow64\unregmp2.exe,-155

测试，把其它快捷方式的备注改为 @%systemroot%\syswow64\unregmp2.exe,-155
结果也是属性无法显示备注，vbs无法读取备注

测试，把快捷方式的备注改为 @%systemroot%\system32\unregmp2.exe,-155
结果是属性可以正常显示备注，vbs可以正常读取备注

备份 syswow64\unregmp2.exe 和 system32\unregmp2.exe 文件
再把这两个文件互换，结果还是
@%systemroot%\system32\unregmp2.exe,-155 正常
@%systemroot%\syswow64\unregmp2.exe,-155 报错

说明与文件无关，而是win10和win11锁定了syswow64
锁定快捷方式的备注不能读取syswow64里的文件

测试，用syswow64\WScript.exe在32环境下运行上述的2个vbs
结果均能正常显示

此时再查看属性，发现可以正常显示备注
包括备份到其它盘的 Windows Media Player.lnk 也能正常显示

说明此时已经解锁了syswow64
快捷方式的备注可以读取syswow64里的文件了

再用二进制读取解锁后的 Windows Media Player.lnk
结果没变 @%systemroot%\syswow64\unregmp2.exe,-155

win10和win11虚拟机恢复镜像后，可以复现上述操作

猜测，这是win10和win11的一个bug
毕竟微软和波音一样，裁减了99%的测试员

czjt1234

'用二进制数据读取lnk文件的备注
Option Explicit
Dim oFSO, oWshShell, s, i

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oWshShell = CreateObject("WScript.Shell")
s = oWshShell.ExpandEnvironmentStrings("%windir%\System32\CScript.exe")
If oFSO.FileExists(s) And LCase(WScript.FullName) <> LCase(s) Then
    s = s & " /nologo """ & WScript.ScriptFullName & """ "
    For Each i In WScript.Arguments
        If InStr(i, " ") > 0 Then i = """" & i & """"
        s = s & i & " "
    Next
    oWshShell.Run "cmd.exe /k " & Left(s, Len(s) - 1)
    WScript.Quit()
End If

s = "C:\ProgramData\Microsoft\Windows\Start Menu\Programs\Windows Media Player.lnk"
wsh.Echo StringData(s)

Function StringData(ByVal lnkFilePath)
    Dim oSteam, arrByte, m, s, p

    p = Right(LinkInfo(lnkFilePath), 6)
    s = "StringData               : " & p & vbCrLf
    Set oSteam = CreateObject("ADODB.Stream")
    oSteam.Type = 1    'adTypeBinary
    oSteam.Mode = 3    'adModeReadWrite
    oSteam.Open()
    oSteam.LoadFromFile lnkFilePath
    oSteam.Position = CLng(p)

    If InStr(LinkFlags(lnkFilePath, 1), "HasName") <> 0 Then
        arrByte = oSteam.Read(2)
        m = bin2Hex(arrByte, 2, 1)
        s = s & "  NAME_STRING            : " & p & vbCrLf & _
                "    CountCharacters      : " & p & " = " & m & vbCrLf
        p = "&H" & Right("000" & Hex(CLng(oSteam.Position)), 4)
        arrByte = oSteam.Read(CLng(m) * 2)
        m = bin2Hex(arrByte, 1, LenB(arrByte))
        s = s & "    String               : " & p & " = " & unicode2chr(m) & vbCrLf
        p = "&H" & Right("000" & Hex(CLng(oSteam.Position)), 4)
    Else
        s = s & "  NAME_STRING            :" & vbCrLf
    End If

    If InStr(LinkFlags(lnkFilePath, 1), "HasRelativePath") <> 0 Then
        arrByte = oSteam.Read(2)
        m = bin2Hex(arrByte, 2, 1)
        s = s & "  RELATIVE_PATH          : " & p & vbCrLf & _
                "    CountCharacters      : " & p & " = " & m & vbCrLf
        p = "&H" & Right("000" & Hex(CLng(oSteam.Position)), 4)
        arrByte = oSteam.Read(CLng(m) * 2)
        m = bin2Hex(arrByte, 1, LenB(arrByte))
        s = s & "    String               : " & p & " = " & unicode2chr(m) & vbCrLf
        p = "&H" & Right("000" & Hex(CLng(oSteam.Position)), 4)
    Else
        s = s & "  RELATIVE_PATH          :" & vbCrLf
    End If

    If InStr(LinkFlags(lnkFilePath, 1), "HasWorkingDir") <> 0 Then
        arrByte = oSteam.Read(2)
        m = bin2Hex(arrByte, 2, 1)
        s = s & "  WORKING_DIR            : " & p & vbCrLf & _
                "    CountCharacters      : " & p & " = " & m & vbCrLf
        p = "&H" & Right("000" & Hex(CLng(oSteam.Position)), 4)
        arrByte = oSteam.Read(CLng(m) * 2)
        m = bin2Hex(arrByte, 1, LenB(arrByte))
        s = s & "    String               : " & p & " = " & unicode2chr(m) & vbCrLf
        p = "&H" & Right("000" & Hex(CLng(oSteam.Position)), 4)
    Else
        s = s & "  WORKING_DIR            :" & vbCrLf
    End If

    If InStr(LinkFlags(lnkFilePath, 1), "HasArguments") <> 0 Then
        arrByte = oSteam.Read(2)
        m = bin2Hex(arrByte, 2, 1)
        s = s & "  COMMAND_LINE_ARGUMENTS : " & p & vbCrLf & _
                "    CountCharacters      : " & p & " = " & m & vbCrLf
        p = "&H" & Right("000" & Hex(CLng(oSteam.Position)), 4)
        arrByte = oSteam.Read(CLng(m) * 2)
        m = bin2Hex(arrByte, 1, LenB(arrByte))
        s = s & "    String               : " & p & " = " & unicode2chr(m) & vbCrLf
        p = "&H" & Right("000" & Hex(CLng(oSteam.Position)), 4)
    Else
        s = s & "  COMMAND_LINE_ARGUMENTS :" & vbCrLf
    End If

    If InStr(LinkFlags(lnkFilePath, 1), "HasIconLocation") <> 0 Then
        arrByte = oSteam.Read(2)
        m = bin2Hex(arrByte, 2, 1)
        s = s & "  ICON_LOCATION          : " & p & vbCrLf & _
                "    CountCharacters      : " & p & " = " & m & vbCrLf
        p = "&H" & Right("000" & Hex(CLng(oSteam.Position)), 4)
        arrByte = oSteam.Read(CLng(m) * 2)
        m = bin2Hex(arrByte, 1, LenB(arrByte))
        s = s & "    String               : " & p & " = " & unicode2chr(m) & vbCrLf
        p = "&H" & Right("000" & Hex(CLng(oSteam.Position)), 4)
    Else
        s = s & "  ICON_LOCATION          :" & vbCrLf
    End If

    StringData = s & ": " & p
    oSteam.Close()
End Function

Function unicode2chr(ByVal m)
    Dim s, i, n
    If Left(m, 2) = "&H" Then m = Right(m, Len(m) - 2)
    s = ""
    n = "&H"
    For i = 1 To Len(m) Step 4
        n = n & Mid(m, i + 2, 1) & Mid(m, i + 3, 1) & Mid(m, i, 1) & Mid(m, i + 1, 1)
        If CLng(n) <> 0 Then s = s & ChrW(CLng(n))
        n = "&H"
    Next
    unicode2chr = s
End Function

Function gbk2chr(ByVal m)
    Dim s, i, n
    If Left(m, 2) = "&H" Then m = Right(m, Len(m) - 2)
    s = ""
    n = "&H"
    For i = 1 To Len(m) Step 2
        n = n & Mid(m, i, 1) & Mid(m, i + 1, 1)
        If CLng(n) > CLng(&H7F) Then
            i = i + 2
            n = n & Mid(m, i, 1) & Mid(m, i + 1, 1)
        End If
        If CLng(n) <> 0 Then s = s & Chr(CLng(n))
        n = "&H"
    Next
    gbk2chr = s
End Function

Function LinkInfo(ByVal lnkFilePath)
    Dim oSteam, arrByte, a(17), i, m, s, p
    a(0) = Right(LinkTargetIDList(lnkFilePath), 6)
    If InStr(LinkFlags(lnkFilePath, 1), "HasLinkInfo") = 0 Then
        LinkInfo = "LinkInfo" & vbCrLf & ": " & a(0)
        Exit Function
    End If
    Set oSteam = CreateObject("ADODB.Stream")
    oSteam.Type = 1    'adTypeBinary
    oSteam.Mode = 3    'adModeReadWrite
    oSteam.Open()
    oSteam.LoadFromFile lnkFilePath
    p = a(0)
    oSteam.Position = CLng(p)
    arrByte = oSteam.Read(28)
    m = bin2Hex(arrByte, 4, 1)
    LinkInfo = ": &H" & Right("000" & Hex(CLng(a(0)) + CLng(m)), 4)
    oSteam.Close()
End Function

Function bin2Hex(ByRef arrByte, ByVal m, ByVal n)
    Dim k, i, s
    k = 1
    If n < m Then k = -1
    s = "&H"
    For i = m To n Step k
        s = s & Right("0" & Hex(AscB(MidB(arrByte, i, 1))), 2)
    Next
    bin2Hex = s
End Function

Function LinkTargetIDList(ByVal lnkFilePath)
    Dim oSteam, arrByte, m, n, s
    If InStr(LinkFlags(lnkFilePath, 1), "HasLinkTargetIDList") = 0 Then
        LinkTargetIDList = "LinkTargetIDList" & vbCrLf & ": &H004C"
        Exit Function
    End If
    Set oSteam = CreateObject("ADODB.Stream")
    oSteam.Type = 1    'adTypeBinary
    oSteam.Mode = 3    'adModeReadWrite
    oSteam.Open()
    oSteam.LoadFromFile lnkFilePath
    oSteam.Position = &H004C
    arrByte = oSteam.Read(2)
    m = bin2Hex(arrByte, 2, 1)
    LinkTargetIDList = ": &H" & Right("000" & Hex(&H004C + 2 + CLng(m)), 4)
    oSteam.Close()
End Function

Function LinkFlags(ByVal lnkFilePath, ByVal x)
    Dim oSteam, arrByte, i, m
    Set oSteam = CreateObject("ADODB.Stream")
    oSteam.Type = 1    'adTypeBinary
    oSteam.Mode = 3    'adModeReadWrite
    oSteam.Open()
    oSteam.LoadFromFile lnkFilePath
    oSteam.Position = &H0014
    arrByte = oSteam.Read(4)
    oSteam.Close()
    LinkFlags = bin2Hex(arrByte, 1, 4)
    If x = 0 Then Exit Function
    m = CLng(LinkFlags)
    i = LinkFlags & vbCrLf
    If (m And &H01000000)  <> 0 Then i = i & "  HasLinkTargetIDList"         & vbCrLf
    If (m And &H02000000)  <> 0 Then i = i & "  HasLinkInfo"                 & vbCrLf
    If (m And &H04000000)  <> 0 Then i = i & "  HasName"                     & vbCrLf
    If (m And &H08000000)  <> 0 Then i = i & "  HasRelativePath"             & vbCrLf
    If (m And &H10000000)  <> 0 Then i = i & "  HasWorkingDir"               & vbCrLf
    If (m And &H20000000)  <> 0 Then i = i & "  HasArguments"                & vbCrLf
    If (m And &H40000000)  <> 0 Then i = i & "  HasIconLocation"             & vbCrLf
    If (m And &H80000000)  <> 0 Then i = i & "  IsUnicode"                   & vbCrLf
    If (m And &H00010000)  <> 0 Then i = i & "  ForceNoLinkInfo"             & vbCrLf
    If (m And &H00020000)  <> 0 Then i = i & "  HasExpString"                & vbCrLf
    If (m And &H00040000)  <> 0 Then i = i & "  RunInSeparateProcess"        & vbCrLf
    If (m And &H00100000)  <> 0 Then i = i & "  HasDarwinID"                 & vbCrLf
    If (m And &H00200000)  <> 0 Then i = i & "  RunAsUser"                   & vbCrLf
    If (m And &H00400000)  <> 0 Then i = i & "  HasExpIcon"                  & vbCrLf
    If (m And &H00800000)  <> 0 Then i = i & "  NoPidlAlias"                 & vbCrLf
    If (m And &H00000200)  <> 0 Then i = i & "  RunWithShimLayer"            & vbCrLf
    If (m And &H00000400)  <> 0 Then i = i & "  ForceNoLinkTrack"            & vbCrLf
    If (m And &H00000800)  <> 0 Then i = i & "  EnableTargetMetadata"        & vbCrLf
    If (m And &H00001000)  <> 0 Then i = i & "  DisableLinkPathTracking"     & vbCrLf
    If (m And &H00002000)  <> 0 Then i = i & "  DisableKnownFolderTracking"  & vbCrLf
    If (m And &H00004000)  <> 0 Then i = i & "  DisableKnownFolderAlias"     & vbCrLf
    If (m And &H00008000&) <> 0 Then i = i & "  AllowLinkToLink"             & vbCrLf
    If (m And &H00000001)  <> 0 Then i = i & "  UnaliasOnSave"               & vbCrLf
    If (m And &H00000002)  <> 0 Then i = i & "  PreferEnvironmentPath"       & vbCrLf
    If (m And &H00000004)  <> 0 Then i = i & "  KeepLocalIDListForUNCTarget" & vbCrLf
    If i <> "" Then i = Left(i, Len(i) - 2)
    LinkFlags = i
End Function
复制代码

jyswjjgdwtdtj

那要是改了syswow64里文件的lnk的目标文件 description还会读去不了吗^_^

czjt1234

回复 3# jyswjjgdwtdtj


    读不了，测试过的，忘写了

jyswjjgdwtdtj

回复 4# czjt1234


    那把一个lnk文件的目标文件改成syswow64里的文件在改成别的，description可以读取吗