Private Declare Function GetFullPathName Lib "kernel32" _
 Alias "GetFullPathNameA" (ByVal lpFileName As String, _
 ByVal nBufferLength As Long, ByVal lpBuffer As String, _
 ByVal lpFilePart As String) As Long
Private Declare Function CreateToolhelpSnapshot Lib _
  "kernel32" Alias "CreateToolhelp32Snapshot" ( _
  ByVal lFlgas As Long, ByVal lProcessID As Long) _
  As Long
 
Private Declare Function ProcessFirst Lib "kernel32" _
  Alias "Process32First" (ByVal hSnapshot As Long, _
  uProcess As PROCESSENTRY32) As Long
 
Private Declare Function ProcessNext Lib "kernel32" _
  Alias "Process32Next" (ByVal hSnapshot As Long, _
  uProcess As PROCESSENTRY32) As Long
 
Private Declare Sub CloseHandle Lib "kernel32" ( _
  ByVal hPass As Long)
 
Private Const TH32CS_SNAPPROCESS As Long = 2&
Private Const MAX_PATH As Long = 260
 
Private Type PROCESSENTRY32
  dwSize As Long
  cntUsage As Long
  th32ProcessID As Long
  th32DefaultHeapID As Long
  th32ModuleID As Long
  cntThreads As Long
  th32ParentProcessID As Long
  pcPriClassBase As Long
  dwflags As Long
  szexeFile As String * MAX_PATH
End Type

Public Sub ShowPath()
  Dim lProcessID As Long
  Dim lSnapshot As Long
  Dim uProcess As PROCESSENTRY32
  Dim lProcessFound As Long
  Dim i As Integer
  Dim sEXEName As String
 
 
    lProcessID = GetCurrentProcessId
 
    lSnapshot = CreateToolhelpSnapshot( _
    TH32CS_SNAPPROCESS, 0&)
 
    ' Fehler?
    If lSnapshot = -1 Then Exit Sub
 
    ' uProcess-Struktur füllen
    With uProcess
      .dwSize = Len(uProcess)
 
      ' alle aktuellen Prozesse durchlaufen
      lProcessFound = ProcessFirst(lSnapshot, uProcess)
      Do While lProcessFound
        If .th32ProcessID = lProcessID Then
          ' ProzessID gefunden
          ' jetzt EXE-Name ermitteln
          If InStr(.szexeFile, Chr$(0)) > 0 Then
            sEXEName = Left$(.szexeFile, _
              InStr(.szexeFile, Chr$(0)) - 1)
          End If
          Exit Do
        Else
          ' ...weitersuchen...
          lProcessFound = ProcessNext(lSnapshot, _
            uProcess)
        End If
      Loop
    End With
 
    Dim nBuffer As String
  Dim nFilePart As String
  Dim nLen As Long
 
  nBuffer = Space$(255)
  nLen = GetFullPathName(sEXEName, Len(nBuffer), nBuffer, nFilePart)
  If nLen Then
    sEXEName = Left$(nBuffer, nLen)
  End If
 
    MsgBox sEXEName
End Sub