• ¡Welcome to Square Theme!
  • This news are in header template.
  • Please ignore this message.
مهمان عزیز خوش‌آمدید. ورود عضــویت


امتیاز موضوع:
  • 9 رای - 3 میانگین
  • 1
  • 2
  • 3
  • 4
  • 5
Title: Get Shortcut or link destination in code
حالت موضوعی
#1
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
گروه دور همی پارسی کدرز
https://t.me/joinchat/GxVRww3ykLynHFsdCvb7eg
 
پاسخ
  


موضوعات مشابه ...
موضوع نویسنده پاسخ بازدید آخرین ارسال
  ساخت shortcut gachboy 1 3,868 02-11-2013، 10:47 AM
آخرین ارسال: Amin_Mansouri
  source code Mini-Task Amin_Mansouri 1 4,085 08-11-2012، 04:09 PM
آخرین ارسال: alakimalaki
  This code allows to extract icons from .dll and .exe files Amin_Mansouri 0 3,145 09-25-2011، 10:30 PM
آخرین ارسال: Amin_Mansouri
  Source code Insert & Delete data from a file Amin_Mansouri 0 3,704 04-29-2011، 03:56 PM
آخرین ارسال: Amin_Mansouri
  Source Code Services Installer Amin_Mansouri 0 3,237 04-22-2011، 12:32 PM
آخرین ارسال: Amin_Mansouri
  Source Code PlayStation MemoryCard image reader and editor Amin_Mansouri 0 3,012 04-19-2011، 12:04 PM
آخرین ارسال: Amin_Mansouri
  Source Code Burn Iso File Amin_Mansouri 0 3,421 04-19-2011، 11:38 AM
آخرین ارسال: Amin_Mansouri

پرش به انجمن:


Browsing: 1 مهمان