[Amin_Mansouri]

Get de destination of an shortcut or link (Windows System) whitout Apis, only code.

درود :
در سورس زیر میتونید ادرس shortcut فایل رو بهش بدید و ذر تابع getlink میتونید لینک اصلی فایل رو بدست بیارید :
برای فراخوانی تابع اینجوری عمل کنید :

کد:

MsgBox getlink("C:\parsicoders - Shortcut.LNK")

اینم کل سورس کد :

کد:

'Www.ParsiCoders.com
' LinkReferer.bas - Modulo para obtener la direccion a la que apunta un Link
'



Option Explicit

Sub main()
    MsgBox getlink("C:\parsicoders - Shortcut.LNK")

End Sub

Public Function getlink(ByVal fileName As String) As String
' DESCRIPCION: Devuelve la direccion a la que apunta un archivo link (*.lnk)
'              de Microsoft Windows.
' IMPORTANTE : Esta funcion no es capaz de resolver la direccion de algunos link's
'              devido a que estos tienen un formato (muy) diferente.
'              *** Para que tengas una idea, compara uno creado por Office ***
'              *** con uno común (creado por tí).                          ***
'
   If ((fileName <> "") And (Dir(fileName) <> "")) Then
      Dim fp As Integer
      Dim header As String
      Dim stpos As Integer, enpos As Integer, hdr As String
      Dim bCH As String * 1
      Const LINK_SIZE_BUFFER = 2048& ' Default 2048 bits, los link's son pequeños!
      Const LINK_START_POS = 100&
      
      fp = FreeFile
      Open fileName For Binary Access Read Lock Write As fp
         header = Input(LINK_SIZE_BUFFER, fp)
      Close fp
      
      hdr = Chr(16) & Chr(0) & Chr(0) & Chr(0)
      stpos = VBA.InStr(LINK_START_POS, header, hdr, vbBinaryCompare) + Len(hdr)
      
      hdr = Chr(0)
      stpos = InStr(stpos, header, hdr, vbBinaryCompare) + Len(hdr)
      Do While (stpos < VBA.Len(header))
        bCH = VBA.Mid$(header, stpos, 1)
        If (bCH <> hdr) Then
            Exit Do
        End If
        stpos = stpos + 1
      Loop
      
      hdr = Chr(0)
      If (stpos > 5) Then
         enpos = InStr(stpos, header, hdr, vbBinaryCompare)
         If (enpos > stpos) Then
            getlink = Mid(header, stpos, (enpos - stpos))
         End If
      End If
   End If
End Function