Récupérer la cible d'un lien windows

Télécharger le projet
Commenter

Description

Récupère le chemin détaillé de la cible d'un lien. Cet exemple n'utilise aucun appel API ou OCX, mais décrypte le fichier original.

Source / Exemple : 


Private Function ResolveWindowsShortcut(fichier As String) As String
'Philippe PUECH - Mai 2001
'puech@inviweb.com
'http://www.inviweb.com
'
'Fonction "beta" permettant de résoudre un lien Windows en se passant de tous
'les appels aux API.
'
'Notes :
'----------
'Je ne me suis attardé que sur le "chemin" sur un réseau local.
'Notez que vous pourrez également adapter cette fonction pour retourner
'des informations concernant le fichier "cible", notamment sa taille et ses
'flags.
'C'est un décodage "simple" basé sur le travail de reverse engineering de
'Jesse Hager que j'ai trouvé sur un site détaillant les différents
'formats de fichiers (http://www.wotsit.org)
'Son document stipule que ce format de fichier LNK est susceptible de changer
'sans préavis et qu'il est préférable d'utiliser les fonctions IShellLink pour
'gérer les liens. Celles-ci étant mal documentées en VB, j'ai préféré adapter
'ses informations.
'
'Utilise deux sous fonctions : fnd et DecToB
On Error GoTo erreur

Dim fnum As Integer
Dim ent() As Byte
    fnum = FreeFile(0)
    Open fichier For Binary As fnum
    debut = 1
    'Chercher le L en première lettre
    ReDim ent(3)
    Get fnum, debut, ent
    If ent(0) = 76 Then
        'c'est un fichier LNK
        'GUID
        ReDim ent(15)
        Get fnum, , ent
        
        'Flags
        ReDim ent(3)
        Get fnum, , ent
        fFlags = DecToB(fnd(CStr((ent(0)))))
        HasShellItemIDList = (Mid(fFlags, 1, 1) = "1")
        FileOrDirectory = (Mid(fFlags, 2, 1) = "1")
        HasDescriptionString = (Mid(fFlags, 3, 1) = "1")
        HasRelativePathString = (Mid(fFlags, 4, 1) = "1")
        HasWorkingDirectory = (Mid(fFlags, 5, 1) = "1")
        HasCommandLineArgs = (Mid(fFlags, 6, 1) = "1")
        HasCustomIcon = (Mid(fFlags, 7, 1) = "1")
        
        'File attributes
        ReDim ent(3)
        Get fnum, , ent
        fFlags = DecToB(fnd(CStr((ent(0)))))
        f_readonly = (Mid(fFlags, 1, 1) = "1")
        f_hidden = (Mid(fFlags, 2, 1) = "1")
        f_system = (Mid(fFlags, 3, 1) = "1")
        f_volumelabel = (Mid(fFlags, 4, 1) = "1")
        f_directory = (Mid(fFlags, 5, 1) = "1")
        f_archive = (Mid(fFlags, 6, 1) = "1")
        f_encrypted = (Mid(fFlags, 7, 1) = "1")
        f_Normal = (Mid(fFlags, 8, 1) = "1")
        f_temporary = (Mid(fFlags, 9, 1) = "1")
        f_sparsefile = (Mid(fFlags, 10, 1) = "1")
        f_reparsepointdata = (Mid(fFlags, 11, 1) = "1")
        f_compressed = (Mid(fFlags, 12, 1) = "1")
        f_offline = (Mid(fFlags, 13, 1) = "1")
        
        'Time 1
        ReDim ent(7)
        Get fnum, , ent
        
        'Time 2
        ReDim ent(7)
        Get fnum, , ent
        
        'Time 3
        ReDim ent(7)
        Get fnum, , ent
        
        'File length
        ReDim ent(3)
        Get fnum, , ent
        taille = Val("&H" + fnd(CStr(Hex(ent(3)))) + fnd(CStr(Hex(ent(2)))) + fnd(CStr(Hex(ent(1)))) + fnd(CStr(Hex(ent(0)))))
        
        'Icon Number
        ReDim ent(3)
        Get fnum, , ent
        
        'ShowWnd
        ReDim ent(3)
        Get fnum, , ent
        
        'HotKey
        ReDim ent(3)
        Get fnum, , ent
        
        'Unknown
        ReDim ent(3)
        Get fnum, , ent
        
        'Unknown
        ReDim ent(3)
        Get fnum, , ent
        
        If HasShellItemIDList Then
            'ShellItemidLength
            ReDim ent(1)
            Get fnum, , ent
            skip = Val("&H" + fnd(CStr(Hex(ent(1)))) + fnd(CStr(Hex(ent(0)))))
            ReDim ent(skip - 1)
            Get fnum, , ent
        End If
        
        'File Location Info
        'Length
        departfli = Loc(fnum)
        ReDim ent(3)
        Get fnum, , ent
        tailleFLI = Val("&H" + fnd(CStr(Hex(ent(3)))) + fnd(CStr(Hex(ent(2)))) + fnd(CStr(Hex(ent(1)))) + fnd(CStr(Hex(ent(0)))))
        '1c
        ReDim ent(3)
        Get fnum, , ent
        'Flags
        ReDim ent(3)
        Get fnum, , ent
        tailleFLI = Val("&H" + fnd(CStr(Hex(ent(3)))) + fnd(CStr(Hex(ent(2)))) + fnd(CStr(Hex(ent(1)))) + fnd(CStr(Hex(ent(0)))))
        'Offset Local VolumeInfo
        ReDim ent(3)
        Get fnum, , ent
        offvolinf = Val("&H" + fnd(CStr(Hex(ent(3)))) + fnd(CStr(Hex(ent(2)))) + fnd(CStr(Hex(ent(1)))) + fnd(CStr(Hex(ent(0)))))
        'Offset BasePath Local
        ReDim ent(3)
        Get fnum, , ent
        offbase = Val("&H" + fnd(CStr(Hex(ent(3)))) + fnd(CStr(Hex(ent(2)))) + fnd(CStr(Hex(ent(1)))) + fnd(CStr(Hex(ent(0)))))
        'Offset Network Volume Info
        ReDim ent(3)
        Get fnum, , ent
        offnetw = Val("&H" + fnd(CStr(Hex(ent(3)))) + fnd(CStr(Hex(ent(2)))) + fnd(CStr(Hex(ent(1)))) + fnd(CStr(Hex(ent(0)))))
        'Offset Remaining Pathname
        ReDim ent(3)
        Get fnum, , ent
        offrem = Val("&H" + fnd(CStr(Hex(ent(3)))) + fnd(CStr(Hex(ent(2)))) + fnd(CStr(Hex(ent(1)))) + fnd(CStr(Hex(ent(0)))))
    
        If offbase <> 0 Then
            Seek fnum, departfli + offbase + 1
            ch = ""
            ReDim ent(0)
            continuer = True
            While continuer
                Get fnum, , ent
                If ent(0) = 0 Then
                    continuer = False
                Else
                    ch = ch + Chr(ent(0))
                End If
            Wend
            f_basepath = ch
        End If
        If offrem <> 0 Then
            Seek fnum, departfli + offrem + 1
            ch = ""
            ReDim ent(0)
            continuer = True
            While continuer
                Get fnum, , ent
                If ent(0) = 0 Then
                    continuer = False
                Else
                    ch = ch + Chr(ent(0))
                End If
            Wend
            f_rem = ch
        End If
        ResolveWindowsShortcut = f_rem + f_basepath
    Else
        ResolveWindowsShortcut = "Not a link file"
    End If
    Close fnum
    Exit Function
erreur:
    ResolveWindowsShortcut = "Error occured in function 'ResolveWindowsShortcut' for " + """" + fichier + """" + "."
End Function

Public Function DecToB(NDecimal As Double) As String
'http://www.ifrance.com/LeSiteWeb/index.htm
Dim NLoop
Dim pd As Long, i As Long
    If NDecimal = 0 Then
    DecToB = "0"
    Exit Function
    End If
    If NDecimal = 1 Then
    DecToB = "1"
    Exit Function
    End If
    NDecimal = NDecimal + 1
    NLoop = -1
    Do Until pd >= NDecimal
    NLoop = NLoop + 1
    pd = 2 ^ NLoop
    Loop
    DecToB = "1"
    NDecimal = NDecimal - 2 ^ (NLoop - 1)
    For i = NLoop - 2 To 0 Step -1
    If 2 ^ i < NDecimal Then
    DecToB = DecToB & "1"
    NDecimal = NDecimal - 2 ^ i
    Else
    DecToB = DecToB & "0"
    End If
    Next i
End Function

Public Function fnd(x As String) As String
'ajoute un zéro devant un chiffre de 1 caractère ex : 1=>01
   If Len(x) = 1 Then
    fnd = "0" + x
   Else
    fnd = x
   End If
End Function

Private Sub Dir1_Change()
  File1.Path = Dir1.Path
End Sub

Private Sub Drive1_Change()
   Dir1.Path = Drive1.Drive
End Sub

Private Sub File1_Click()
  MsgBox ResolveWindowsShortcut(File1.Path + "\" + File1.filename)
End Sub
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (Philippe PUECH)