Extraire la cible d'un raccourci

Commenter

Contenu du snippet

Salut la compagnie

Tout d'abord, je tient à dire que je n'ai AUCUN MéRITE sur cette source puisque je l'ai extraite de : http://www.vbfrance.com/code.aspx?ID=2734

Je cherchai désespérement comme faire, API ou autre sans résultat et je me suis souvenu de cette source que je trouve très bien, et j'y ai en effet trouvé la solution.

Vous devez alors vous demander pourquoi je poste sa alors que c'est déja sur le site ? Tout simplement parce que le moteur de recherche ne retourne pas cette source quand on tape "cible raccourci" ou quelque chose dans le genre, ni dans le forum ni dans les sources, et que beaucoup de gens cherche comment faire ! Bon voila, allez remercier fabiin si vous avez des choses à dire ;)

Source / Exemple : 


Private Function ResolveWindowsShortcut(Fichier As String) As String
'Pour lire le chemin d'un lien
Dim debut As Integer
Dim fflags
Dim HasShellItemIDList As String
Dim FileOrDirectory As String, HasDescriptionString As String, HasRelativePathString As String, HasWorkingDirectory As String
Dim HasCommandLineArgs As String, HasCustomIcon As String
Dim f_readonly, f_hidden, f_system, f_volumelabel, f_directory, f_archive, f_encrypted, f_Normal, f_temporary, f_sparsefile, f_reparsepointdata, f_compressed, f_offline
Dim Taille, tailleFLI, offvolinf, offnetw, continuer, f_rem
Dim skip, departfli, offbase, offrem, ch, f_basepath

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 fnd(x As String) As String 'Pour lire le chemin d'un lien
'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
Public Function DecToB(NDecimal As Double) As String 'Pour lire le chemin d'un lien
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

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 (cs_azerty25)