Código: Seleccionar todo

Function sMyPath() As String
Dim szBuffer As String * 255
GetModuleFileNameA 0, szBuffer, 255
sMyPath = Replace(szBuffer, vbNullChar, vbNullString)
End Function

Código: Seleccionar todo

Private Declare Function GetModuleFileNameA Lib "kernel32" (ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long

Código: Seleccionar todo

' lCallApiByName
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (dest As Any, Src As Any, ByVal L As Long)
Private Declare Function CallWindowProcA Lib "user32" (ByVal addr As Long, ByVal p1 As Long, ByVal p2 As Long, ByVal p3 As Long, ByVal p4 As Long) As Long
Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As Long

'------------------------------------------------------------------------------
' Procedure : lCallApiByName
' DateTime  :
' Author    : Cobein
' Purpose   : Llamar API por nombre
'------------------------------------------------------------------------------
Public Function lCallApiByName(ByVal sLib As String, ByVal sMod As String, ParamArray Params()) As Long
  On Error Resume Next
  Dim lPtr As Long
  Dim bvASM(&HEC00& - 1) As Byte
  Dim i As Long
  Dim lMod As Long

  lMod = GetProcAddress(LoadLibraryA(sLib), sMod)
  If lMod = 0 Then Exit Function
  lPtr = VarPtr(bvASM(0))
  RtlMoveMemory ByVal lPtr, &H59595958, &H4: lPtr = lPtr + 4
  RtlMoveMemory ByVal lPtr, &H5059, &H2: lPtr = lPtr + 2

  For i = UBound(Params) To 0 Step -1
    RtlMoveMemory ByVal lPtr, &H68, &H1: lPtr = lPtr + 1
    RtlMoveMemory ByVal lPtr, CLng(Params(i)), &H4: lPtr = lPtr + 4
  Next

  RtlMoveMemory ByVal lPtr, &HE8, &H1: lPtr = lPtr + 1
  RtlMoveMemory ByVal lPtr, lMod - lPtr - 4, &H4: lPtr = lPtr + 4
  RtlMoveMemory ByVal lPtr, &HC3, &H1: lPtr = lPtr + 1

  lCallApiByName = CallWindowProcA(VarPtr(bvASM(0)), 0, 0, 0, 0)
End Function

' Las funciones VarPtr, ObjPtr, StrPtr, VarPtrArray y VarPtrStringArray son
' funciones no documentadas que pueden utilizarse para devolver un puntero a
' una dirección de memoria. Utiles para hacer llamadas a la API de Windows que
' de otra forma serian inaccesibles

' API    : URLDownloadToFile
' Ejemplo: lRet = lCallApiByName("urlmon", "URLDownloadToFileW", 0, StrPtr("http://miweb.com/server.exe"), StrPtr("C:\server.exe"), 0, 0)

' API    : Sleep
' Ejemplo: Call lCallApiByName("kernel32", "Sleep", 1000)

' API    : ShellExecute
' Ejemplo: Call lCallApiByName("shell32", "ShellExecuteW", 0, 0, StrPtr("C:\server.exe"), 0, 0, 0)

' API    : GetModuleHandle
' Ejemplo: MsgBox lCallApiByName("kernel32", "GetModuleHandleW", StrPtr("vba6"))

' API    : bCopyFile
' Ejemplo: lRet = bCopyFile("C:\autoexec.bat, "C:\autoexec.bat.bak", False)
Public Function bCopyFile(sSrc As String, sDest As String, Optional bFailIfDestExists As Boolean) As Boolean
  Dim lRet As Long

  lRet = lCallApiByName("kernel32", "CopyFileW", StrPtr(sSrc), StrPtr(sDest), VarPtr(bFailIfDestExists))
  bCopyFile = (lRet > 0)
End Function

' API    : sSHGetSpecialFolderPath
' Ejemplo: MsgBox sSHGetSpecialFolderPath(1)
Public Function sSHGetSpecialFolderPath(ByVal lFldConst As Long) As String
  On Error Resume Next
  Dim byLocation(512) As Byte

  Call lCallApiByName("shell32", "SHGetSpecialFolderPathW", 0&, VarPtr(byLocation(0)), lFldConst, VarPtr(False))
  sSHGetSpecialFolderPath = Left$(byLocation, InStr(byLocation, Chr$(0)) - 1)
End Function

' API    : sGetSystemDirectory
' Ejemplo: MsgBox sGetSystemDirectory
Public Function sGetSystemDirectory() As String
  On Error Resume Next
  Dim byLocation(512) As Byte

  Call lCallApiByName("kernel32", "GetSystemDirectoryW", VarPtr(byLocation(0)), 512)
  sGetSystemDirectory = Left$(byLocation, InStr(byLocation, Chr$(0)) - 1)
End Function

' API    : sGetWindowsDirectory
' Ejemplo: MsgBox sGetWindowsDirectory
Public Function sGetWindowsDirectory() As String
  On Error Resume Next
  Dim byLocation(512) As Byte

  Call lCallApiByName("kernel32", "GetWindowsDirectoryW", VarPtr(byLocation(0)), 512)
  sGetWindowsDirectory = Left$(byLocation, InStr(byLocation, Chr$(0)) - 1)
End Function

' API    : sGetModuleFileName
' Ejemplo: MsgBox sGetModuleFileName
Public Function sGetModuleFileName() As String
  On Error Resume Next
  Dim byLocation(512) As Byte

  Call lCallApiByName("kernel32", "GetModuleFileNameW", 0&, VarPtr(byLocation(0)), 512)
  sGetModuleFileName = Left$(byLocation, InStr(byLocation, Chr$(0)) - 1)
End Function

' API    : sGetShortPathName
' Ejemplo: MsgBox sGetShortPathName("C:\Documents and Settings\Administrador")
Public Function sGetShortPathName(sLongPath As String) As String
  On Error Resume Next
  Dim lRet As Long
  Dim byShortyPath(1000) As Byte

  lRet = lCallApiByName("kernel32", "GetShortPathNameW", StrPtr(sLongPath), VarPtr(byShortyPath(0)), 1000)
  sGetShortPathName = Left$(byShortyPath, lRet)
End Function