+- Parsi Coders (http://parsicoders.com)
+-- انجمن: Software Development Programming (http://parsicoders.com/forumdisplay.php?fid=37)
+--- انجمن: Visual Basic Programming (http://parsicoders.com/forumdisplay.php?fid=39)
+---- انجمن: Visual Basic 6 (http://parsicoders.com/forumdisplay.php?fid=44)
+---- موضوع: Get Shortcut or link destination in code (/showthread.php?tid=927)
Get Shortcut or link destination in code - Amin_Mansouri - 09-26-2011
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