Extraire la cible d'un raccourci

Soyez le premier à donner votre avis sur cette source.

Snippet vu 8 370 fois - Téléchargée 30 fois

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

Ajouter un commentaire

Commentaires

Messages postés
11
Date d'inscription
lundi 2 janvier 2006
Statut
Membre
Dernière intervention
3 novembre 2006

Merci beaucoup
Messages postés
44
Date d'inscription
jeudi 27 juin 2002
Statut
Membre
Dernière intervention
20 novembre 2008

Un petit test sous Windows XP Pro m'a permis de voir que cela ne fonctionnait pas pour les raccourci avec un lecteur réseau (le lecteur réseau n'apparaît pas).
Je débogue pour voir où le trouver...
Messages postés
3757
Date d'inscription
mardi 23 septembre 2003
Statut
Modérateur
Dernière intervention
13 mars 2006
15
Mince alors !!

G ajouté un commentaire et je ne le vois pas. Bon, G du faire une fausse manip. Je recommence donc :

Merci à toi azerty25 de m'avoir aiguillé sur cette source.
Comme toi, je cherchais un moyen connaître la cible des raccourcis (où qu'ils se trouvent) et savoir s'ils étaient encore valable. D'une part pour faire un peu de ménage sur mes PC et d'autre part (dans le cadre d'un projet de gestion de parc) savoir ce qui était installé et utilisé sur les quelques centaines de PC du parc de ma boite.

Donc, merci à toi de m'avoir donné la piste.

Quand je publierai mon code final, faudra que je fasse un remerciement à la Drucker car je ne sais pas si je vais me souvenir de tous ceux qui m'ont aidé, directement ou indirectement (même si, fierté oblige, une bonne partie du code sort de ma petite tête, quoique, si c sorti de ma tête, d'autres ont du avoir les mêmes idées) enfin, bref, je ne gagne pas de fric sur le code final et il sera à la disposition de tous.

Codialement

CanisLupus

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.