Link Dateien parsen

Eine Verknüpfung als Link-Datei zu erstellen, ist relativ leicht. Die .dll mso97.dll (Office 2000 mso9.dll) enthält die Funktion  #315, die so etwas macht. Das Ausführen von .lnk - Dateien funzt gut mittels ShellExecute.
Aber das Auslesen der Informationen in dieser Datei mittels VB(A) bereitet ohne C- Programme oder dll's Probleme, bzw. funktioniert nicht. Da aber jede Datei eine bestimmte Struktur hat, kann man versuchen, diese zu entschlüsseln und die Daten direkt auslesen. Wotsit.com ist eine gute Anlaufstelle für Dateiformate und dort findet sich auch eine Beschreibung. Leider kann MS diese Struktur jederzeit ändern, deshalb auch eine GUID in der Link-Datei, an der das Betriebssystem die Version erkennt. So passt auch zumindestens unter Win 98, XP und Win 2000 nicht alles zu dieser Beschreibung. Ich habe meinen Code aber den geänderten Gegebenheiten angepasst und es läuft relativ gut. Wenn Links von Programmen angelegt werden, kann es schon mal vorkommen, dass nicht alle Infos zur Verfügung stehen. Ein Doppelklick auf den Link wirkt da manchmal wahre Wunder.
Ansonsten einfach mal testen!

Beispieldatei (linken.zip 33 KB)

'########################################################
'# In ein Modul
'########################################################
Option Explicit

Sub test()
Dim Linkname As String
'Pfad anpassen
Linkname = "C:\Dokumente und Einstellungen\" _
    & "schwimmer\Desktop\Analysis.pdf.lnk"
LinkInfos Linkname
End Sub

Public Sub LinkInfos(Linkname As String)
Dim Linkklasse As New clsLink
Dim Itemlist, i As Long
'Blattname anpassen
On Error Resume Next
Worksheets("LinkinfosListe").Cells.Clear
If Linkname = "" Then Exit Sub
With Linkklasse
    .Linkpath = Linkname
    Eintragen "Archive = " & .Archive, 2, "LinkinfosListe"
    Eintragen "Kompressed = " & .Kompressed
    Eintragen "Temporary = " & .Temporary
    Eintragen "Directory = " & .Directory
    Eintragen "System = " & .System
    Eintragen "Hidden = " & .Hidden
    Eintragen "ReadOnly = " & .ReadOnly
    Eintragen "GUID = " & .GUID
    Eintragen "Filelength = " & .Filelength
    Eintragen "IconNumber = " & .IconNumber
    Eintragen "IconPath = " & .IconPath
    Eintragen "CreationTime = " & .CreationTime
    Eintragen "LastAccessTime = " & .LastAccessTime
    Eintragen "LastModifyTime = " & .LastModifyTime
    Eintragen "VolumeArt = " & .VolumeArt
    Eintragen "VolumeSerial = " & .VolumeSerial
    Eintragen "LocalVolumeName = " & .LocalVolumeName
    Eintragen "LocalPath = " & .LocalPath
    Eintragen "FinalPath = " & .FinalPath
    Eintragen "NetworkVolumeName = " & .NetworkVolumeName
    Eintragen "ShareName = " & .ShareName
    Eintragen "RelativePath = " & .RelativePath
    Eintragen "ShowModus = " & .ShowModus
    Eintragen "Workdirectory = " & .Workdirectory
    Eintragen "Commandline Arguments = " & .CommandlineArgs
    Eintragen "Description = " & .Description
    Itemlist = .Itemlist
    For i = 1 To UBound(Itemlist)
        Eintragen "ITEM " & i & " = " & Itemlist(i)
    Next
End With
End Sub

Private Sub Eintragen(myWert As String, _
    Optional Startrow As Long, _
    Optional Blattname As String)
'Werte in Blatt eintragen
Static zeile As Long, Blatt As String
If Blattname <> "" Then Blatt = Blattname
If Startrow <> 0 Then zeile = Startrow
With Worksheets(Blatt)
    .Cells(zeile, 1) = myWert
End With
zeile = zeile + 1
End Sub

'########################################################
'# In eine Klasse mit Namen clsLink
'########################################################

Option Explicit
Private Declare Function StringFromGUID2 Lib "ole32" _
    (ByRef rguid As GUID, _
     ByVal lpsz As Long, _
     ByVal cchMax As Long) As Long
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 Type GUID
    f1          As Long
    f2          As Integer
    f3          As Integer
    f4(0 To 7)  As Byte
End Type

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 DoubleLong
    a As Long
    b As Long
End Type

Private Type SingleCur
    a As Currency
End Type

Private iLinkpath As String
Private iFinalPath As String
Private iDescription As String
Private iGUID As String
Private iCommandlineArgs As String
Private iWorkdirectory As String
Private iIconPath As String
Private iIconNumber As String
Private iLocalPath As String
Private iNetworkVolumeName As String
Private iShareName As String
Private iCreationTime As String
Private iLastAccessTime As String
Private iLastModifyTime As String
Private iRelativePath As String
Private iEncrypted As Boolean
Private iReadOnly As Boolean
Private iHidden As Boolean
Private iSystem As Boolean
Private iDirectory As Boolean
Private iArchive As Boolean
Private iTemp As Boolean
Private iKomprimiert As Boolean
Private iFilelänge As Long
Private iShow As String
Private iItem() As String
Private iVolumeart As String
Private iVolumeSerial As Currency
Private iLocalVolumeName As String

Private Sub ParseLnk()
Dim ff As Long, länge As Long, intLänge As Integer
Dim BOL As Long, ArrBuff() As Byte, BuffLong As Long
Dim MyGuid As GUID, BuffStr As String, BuffByte As String * 1
Dim zeiger As Long, i As Long, k As Long
Dim IDList As Boolean, LocationList As Boolean
Dim Beschreibung As Boolean, RelPfad As Boolean
Dim WorkDir As Boolean, CommandlineArgs As Boolean
Dim UserdefIcon As Boolean
Dim offsetVol As Long, VolumeFlag As Long
Dim VolLänge As Long, OffsetLocalPath As Long
Dim OffsetNetzwerk As Long, OffsetFinalPath As Long
Dim myFileTime As FILETIME
If iLinkpath = "" Then Close: Zurücksetzen: Exit Sub
If Dir(iLinkpath) = "" Then Close: Zurücksetzen: Exit Sub
ff = FreeFile
zeiger = 0
Open iLinkpath For Binary As ff
    Get ff, , BuffLong
    'Magic L
    If BuffLong <> &H4C Then Close: Zurücksetzen: Exit Sub
    zeiger = zeiger + 4
    'GUID
    Get ff, , MyGuid
    iGUID = String(255, 0)
    länge = StringFromGUID2(MyGuid, StrPtr(iGUID), 255)
    If länge Then iGUID = Left$(iGUID, länge - 1)
    zeiger = zeiger + Len(MyGuid)
    'Flags
    Get ff, , BuffLong
    If BuffLong And 2 ^ 0 Then IDList = True
    If BuffLong And 2 ^ 1 Then LocationList = True
    If BuffLong And 2 ^ 2 Then Beschreibung = True
    If BuffLong And 2 ^ 3 Then RelPfad = True
    If BuffLong And 2 ^ 4 Then WorkDir = True
    If BuffLong And 2 ^ 5 Then CommandlineArgs = True
    If BuffLong And 2 ^ 6 Then UserdefIcon = True
    zeiger = zeiger + 4
    'File Attribute Ziel
    Get ff, , BuffLong
    If BuffLong And 2 ^ 0 Then iReadOnly = True
    If BuffLong And 2 ^ 1 Then iHidden = True
    If BuffLong And 2 ^ 2 Then iSystem = True
    If BuffLong And 2 ^ 4 Then iDirectory = True
    If BuffLong And 2 ^ 5 Then iArchive = True
    If BuffLong And 2 ^ 6 Then iEncrypted = True
    If BuffLong And 2 ^ 8 Then iTemp = True
    If BuffLong And 2 ^ 11 Then iKomprimiert = True
    zeiger = zeiger + 4
    'File Attribute Zeit
    Get ff, , myFileTime
    iCreationTime = myLocalTimeToDateString(myFileTime)
    Get ff, , myFileTime
    iLastModifyTime = myLocalTimeToDateString(myFileTime)
    Get ff, , myFileTime
    iLastAccessTime = myLocalTimeToDateString(myFileTime)
    zeiger = zeiger + 24
    'Filelänge
    Get ff, , iFilelänge
    zeiger = zeiger + 4
    'Iconnummer
    Get ff, , BuffLong
    iIconNumber = BuffLong
    zeiger = zeiger + 4
    'Show
    Get ff, , BuffLong
    If BuffLong = 1 Then iShow = "Show Normal"
    If BuffLong = 2 Then iShow = "Show Minimized"
    If BuffLong = 3 Then iShow = "Show Maximized"
    zeiger = zeiger + 16
    'ID-List
    If IDList Then
        ReDim iItem(1 To 10)
        Get ff, zeiger + 1, intLänge
        BOL = zeiger + intLänge + 2
        zeiger = zeiger + 2
        Do
            i = i + 1
            Get ff, zeiger + 1, intLänge
            BuffStr = ""
            If i = 2 Then
                k = k + 1
                BuffStr = "   "
                Get ff, zeiger + 4, BuffStr
               iItem(k) = BuffStr
            ElseIf i > 2 Then
                k = k + 1
                If UBound(iItem) < k Then _
                    ReDim Preserve iItem(1 To k)
                Get ff, zeiger + 15, BuffByte
                Do While BuffByte <> Chr(0)
                     BuffStr = BuffStr & BuffByte
                     Get ff, , BuffByte
                Loop
                iItem(k) = BuffStr
            End If
            zeiger = zeiger + intLänge
        Loop While (zeiger + 3) < BOL
        If k Then
            ReDim Preserve iItem(1 To k)
        Else
            ReDim iItem(0)
        End If
    End If
    'Alle folgenden Offsets beginnen ab BOL
    zeiger = BOL
    If LocationList Then
        zeiger = zeiger + 8
        Get ff, zeiger + 1, VolumeFlag
        Get ff, , offsetVol
        Get ff, , OffsetLocalPath
        Get ff, , OffsetNetzwerk
        Get ff, , OffsetFinalPath
        zeiger = zeiger + 20
        'Volumeinfos
        If VolumeFlag And 1 Then
            zeiger = BOL + offsetVol
            Get ff, zeiger + 1, VolLänge
            zeiger = zeiger + 4
            Get ff, zeiger + 1, BuffLong
            Select Case BuffLong
                Case 0
                    iVolumeart = "Unbekannt"
                Case 1
                    iVolumeart = "NoRoot"
                Case 2
                    iVolumeart = "Removeable"
                Case 3
                    iVolumeart = "Harddisk"
                Case 4
                    iVolumeart = "Netzwerk-Drive"
                Case 5
                    iVolumeart = "CD-Rom"
                Case 6
                    iVolumeart = "Ramdrive"
            End Select
            'Serial Number BuffLong
            Get ff, , BuffLong
            iVolumeSerial = SignedLongToUnsignedCur(BuffLong)
            zeiger = zeiger + 12
            'Volumename
            iLocalVolumeName = String(BOL + offsetVol _
                + VolLänge - zeiger, 0)
            Get ff, zeiger + 1, iLocalVolumeName
            'Local Pfad
            zeiger = BOL + OffsetLocalPath
            Get ff, zeiger + 1, BuffByte
            iLocalPath = ""
            Do While BuffByte <> Chr(0)
                 iLocalPath = iLocalPath & BuffByte
                 Get ff, , BuffByte
            Loop
            zeiger = zeiger + Len(iLocalPath) + 1
        End If
        'Netzwerk-Volumeinfos
        If VolumeFlag And 2 Then
            zeiger = BOL + OffsetNetzwerk
            Get ff, zeiger + 1, VolLänge
            zeiger = zeiger + 20
            Get ff, zeiger + 1, BuffByte
            iShareName = ""
            Do While BuffByte <> Chr(0)
                 iShareName = iShareName & BuffByte
                 Get ff, , BuffByte
            Loop
            zeiger = zeiger + Len(iShareName) + 1
        End If
        'Final Path Name
        zeiger = BOL + OffsetFinalPath
        Get ff, zeiger + 1, BuffByte
        iFinalPath = ""
        Do While BuffByte <> Chr(0)
             iFinalPath = iFinalPath & BuffByte
             Get ff, , BuffByte
        Loop
        zeiger = zeiger + Len(iFinalPath) + 1
        'Description
        If Beschreibung = True Then
            Get ff, zeiger + 1, intLänge
            ReDim ArrBuff(1 To intLänge * 2)
            Get ff, , ArrBuff
            iDescription = ArrBuff
            zeiger = zeiger + 2 + intLänge * 2
        End If
        'Relativer Pfad
        If RelPfad = True Then
            Get ff, zeiger + 1, intLänge
            ReDim ArrBuff(1 To intLänge * 2)
            Get ff, , ArrBuff
            iRelativePath = ArrBuff
            zeiger = zeiger + 2 + intLänge * 2
        End If
        'Workdir
        If WorkDir = True Then
            Get ff, zeiger + 1, intLänge
            ReDim ArrBuff(1 To intLänge * 2)
            Get ff, , ArrBuff
            iWorkdirectory = ArrBuff
            zeiger = zeiger + 2 + intLänge * 2
        End If
        'Commandline
        If CommandlineArgs = True Then
            Get ff, zeiger + 1, intLänge
            ReDim ArrBuff(1 To intLänge * 2)
            Get ff, , ArrBuff
            iCommandlineArgs = ArrBuff
            zeiger = zeiger + 2 + intLänge * 2
        End If
        'Iconpfad
        If UserdefIcon = True Then
            Get ff, zeiger + 1, intLänge
            ReDim ArrBuff(1 To intLänge * 2)
            Get ff, , ArrBuff
            iIconPath = ArrBuff
            zeiger = zeiger + 2 + intLänge * 2
        End If
    End If
Close
End Sub

Private Function SignedLongToUnsignedCur(x As Long) As Currency
Dim a As DoubleLong, b As SingleCur
a.a = x
LSet b = a
SignedLongToUnsignedCur = b.a * 10000
End Function

Public Property Let Linkpath(ByVal vNewValue As String)
    Zurücksetzen
    iLinkpath = vNewValue
    ParseLnk
End Property

Public Property Get Itemlist()
    Itemlist = iItem
End Property

Public Property Get VolumeSerial() As Currency
    VolumeSerial = iVolumeSerial
End Property

Public Property Get VolumeArt() As String
    VolumeArt = iVolumeart
End Property

Public Property Get ShowModus() As String
    ShowModus = iShow
End Property

Public Property Get Filelength() As Long
    Filelength = iFilelänge
End Property

Public Property Get Kompressed() As Boolean
    Kompressed = iKomprimiert
End Property

Public Property Get Temporary() As Boolean
    Temporary = iTemp
End Property

Public Property Get Archive() As Boolean
    Archive = iArchive
End Property

Public Property Get Directory() As Boolean
    Directory = iDirectory
End Property

Public Property Get System() As Boolean
    System = iSystem
End Property

Public Property Get Hidden() As Boolean
    Hidden = iHidden
End Property

Public Property Get ReadOnly() As Boolean
    ReadOnly = iReadOnly
End Property

Public Property Get Encrypted() As Boolean
    Encrypted = iEncrypted
End Property

Public Property Get CreationTime() As String
    CreationTime = iCreationTime
End Property

Public Property Get LastAccessTime() As String
    LastAccessTime = iLastAccessTime
End Property

Public Property Get LastModifyTime() As String
    LastModifyTime = iLastModifyTime
End Property

Public Property Get CommandlineArgs() As String
    CommandlineArgs = iCommandlineArgs
End Property

Public Property Get IconNumber() As String
    IconNumber = iIconNumber
End Property

Public Property Get IconPath() As String
    IconPath = iIconPath
End Property

Public Property Get RelativePath() As String
    RelativePath = iRelativePath
End Property

Public Property Get Workdirectory() As String
    Workdirectory = iWorkdirectory
End Property

Public Property Get GUID() As String
    GUID = iGUID
End Property

Public Property Get FinalPath() As String
    FinalPath = iFinalPath
End Property

Public Property Get LocalVolumeName() As String
    LocalVolumeName = iLocalVolumeName
End Property

Public Property Get LocalPath() As String
    LocalPath = iLocalPath
End Property

Public Property Get NetworkVolumeName() As String
    NetworkVolumeName = iNetworkVolumeName
End Property

Public Property Get ShareName() As String
    ShareName = iShareName
End Property

Public Property Get Description() As String
    Description = iDescription
End Property

Private Sub Zurücksetzen()
iFinalPath = ""
iLocalVolumeName = ""
iDescription = ""
iGUID = ""
iCommandlineArgs = ""
iWorkdirectory = ""
iIconPath = ""
iIconNumber = ""
iLocalVolumeName = ""
iLocalPath = ""
iNetworkVolumeName = ""
iShareName = ""
iCreationTime = ""
iLastAccessTime = ""
iLastModifyTime = ""
iRelativePath = ""
iEncrypted = False
iReadOnly = False
iHidden = False
iSystem = False
iDirectory = False
iArchive = False
iTemp = False
iKomprimiert = False
iFilelänge = 0
iShow = ""
iVolumeart = ""
iVolumeSerial = 0
End Sub

Private Function myLocalTimeToDateString( _
    MyTime As FILETIME) As String
Dim myLocalTime As SYSTEMTIME
'Ländereinstellung Zeit beachten
FileTimeToLocalFileTime MyTime, MyTime
'In eine Systemzeit umwandeln
FileTimeToSystemTime MyTime, myLocalTime
'In einen formatierten String umwandeln
myLocalTimeToDateString = Format( _
    DateSerial(myLocalTime.wYear, _
    myLocalTime.wMonth, myLocalTime.wDay) _
    + TimeSerial(myLocalTime.wHour, _
    myLocalTime.wMinute, myLocalTime.wSecond) _
    , "DD.MM.YYYY hh:nn:ss")
End Function