批处理之家 - Powered by Discuz! Board

'用二进制数据读取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