duplicate filename in process in vb6

See more:

VB8

VB6

VB

VBA

i use below code to get list of opened files in proccess this code works fine but sometime this code get duplicate file name in current proccess.for example if a video file abc.mpg open in media player and a def.mpg file opened in km player if i close abc.mpg file this code still show the abc.mpg file is runing.
here is my code

Private Const DUPLICATE_SAME_ACCESS           As Long = &H2
       Private Const DUPLICATE_CLOSE_SOURCE          As Long = &H1
       Private Const STATUS_INFO_LENGTH_MISMATCH     As Long = &HC0000004
       Private Const PROCESS_ALL_ACCESS              As Long = &H1F0FFF
       Private Const FILE_MAP_READ                   As Long = &H4
       Private Const PAGE_READONLY                   As Long = &H2
       Private Const HEAP_ZERO_MEMORY                As Long = &H8
       Private Const TOKEN_ADJUST_PRIVILEGES         As Long = &H20
       Private Const SE_PRIVILEGE_ENABLED            As Long = &H2
       Private Const SE_PRIVILEGE_NAME               As String = "SeDebugPrivilege"
       Private Const TOKEN_QUERY                     As Long = &H8

       Private Const SystemHandleInformation         As Long = &H10
      ' 16 bytes.
       Private Type SYSTEM_HANDLE_INFORMATION
       ProcessID           As Long
       ObjectTypeNumber    As Byte
       Flags               As Byte
       Handle              As Integer
       Object_Pointer      As Long
       GrantedAccess       As Long
       End Type

       Private Type LUID
       LowPart             As Long
       HighPart            As Long
       End Type

   Private Type TOKEN_PRIVILEGES
       PrivilegeCount      As Long
       LuidUDT             As LUID
       Attributes          As Long
   End Type

   Private Declare Function GetProcessHeap Lib "kernel32.dll" () As Long
   Private Declare Function HeapAlloc Lib "kernel32.dll" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
   Private Declare Function HeapFree Lib "kernel32.dll" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long) As Long
   Private Declare Function HeapDestroy Lib "kernel32.dll" (ByVal hHeap As Long) As Long
   Private Declare Function NtQuerySystemInformation Lib "ntdll.dll" (ByVal SystemInformationClass As Long, ByVal pSystemInformation As Long, ByVal SystemInformationLength As Long, ByRef ReturnLength As Long) As Long
   Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
   Private Declare Function DuplicateHandle Lib "kernel32.dll" (ByVal hSourceProcessHandle As Long, ByVal hSourceHandle As Long, ByVal hTargetProcessHandle As Long, ByRef lpTargetHandle As Long, ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwOptions As Long) As Long
   Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
   Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
   Private Declare Function CreateFileMappingW Lib "kernel32" (ByVal hFile As Long, ByVal lpFileMappigAttributes As Long, ByVal flProtect As Long, ByVal dwMaximumSizeHigh As Long, ByVal dwMaximumSizeLow As Long, ByVal lpName As String) As Long
   Private Declare Function MapViewOfFile Lib "kernel32" (ByVal hFileMappingObject As Long, ByVal dwDesiredAccess As Long, ByVal dwFileOffsetHigh As Long, ByVal dwFileOffsetLow As Long, ByVal dwNumberOfBytesToMap As Long) As Long
   Private Declare Function GetMappedFileNameW Lib "Psapi.dll" (ByVal hProcess As Long, ByVal lpv As Long, ByVal lpFileName As Long, ByVal nSize As Long) As Long
   Private Declare Function UnmapViewOfFile Lib "kernel32" (ByVal lpBaseAddress As Long) As Long
   Private Declare Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
   Private Declare Function LookupPrivilegeValueA Lib "advapi32" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long
   Private Declare Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As Any, ReturnLength As Any) As Long
   Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal Length As Long)
   Private Declare Sub RtlZeroMemory Lib "kernel32.dll" (Destination As Any, ByVal Length As Long)
   Private Declare Function GetModuleFileNameExW Lib "Psapi.dll" (ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFileName As Long, ByVal nSize As Long) As Long

   Dim HandleInfo()    As SYSTEM_HANDLE_INFORMATION
   Dim m_cHandles      As Long
   Dim hProcess        As Long
   Dim hHandle         As Long
   Dim szName          As String
   Dim szAppName       As String

   Public Sub QueryHandlesBuffer()

     ' The following method obtains all the handles on the system
     ' followed by an array of SYSTEM_HANDLE_INFORMATION structs
     ' that can be used to obtain information.

     ' Need to be admin on XP
     ' Need to be admin and elevated on vista and above.
     ' Need to have SE_DEBUG_PRIVS

     ' Use DUPLICATE_CLOSE_SOURCE to close the handle to the remote
     ' process and local process when passed to DuplicateHandle.

     Dim lpBufferHandles   As Long
     Dim Length            As Long
     Dim ret               As Long
     Dim n                 As Long

     ' 256 byte offset
     Length = &H100
       ' Allocate block of memory
     lpBufferHandles = HeapAlloc(GetProcessHeap, HEAP_ZERO_MEMORY, Length)
       ' Check if valid buffer
     If lpBufferHandles = 0 Then
       Exit Sub
     End If

     ' Obtain the size required for SystemHandleInformation class
     While (NtQuerySystemInformation(SystemHandleInformation, lpBufferHandles, Length, ret) = STATUS_INFO_LENGTH_MISMATCH)
       Length = Length * 2
       ' free memory
       HeapFree GetProcessHeap, 0, lpBufferHandles
       ' allocate memory
       lpBufferHandles = HeapAlloc(GetProcessHeap, HEAP_ZERO_MEMORY, Length)
     Wend

     ' Check if valid buffer
     If lpBufferHandles = 0 Then
       Exit Sub
     End If

     ' The number of system handles first 4 bytes.
     m_cHandles = ReadLong(lpBufferHandles)
     ' Resize array to system handle count.
     ReDim HandleInfo(m_cHandles) As SYSTEM_HANDLE_INFORMATION
     ' Initialize memory
     RtlZeroMemory HandleInfo(0), LenB(HandleInfo(0)) * m_cHandles
     ' Copy the information into the array
     RtlMoveMemory HandleInfo(0), ByVal lpBufferHandles + 4, LenB(HandleInfo(0)) * m_cHandles
     ' free memory
     HeapFree GetProcessHeap, 0, lpBufferHandles

     ' Get information from the SYSTEM_HANDLE_INFORMATION arrays
       For n = 0 To m_cHandles - 1
     ' Check if the object is a type FILE.
       If HandleInfo(n).ObjectTypeNumber = 28 Then ' 26 for Win2K
     ' Get real process handle.
         OpenProcessForHandle HandleInfo(n).ProcessID
     ' Have to duplicate the file handle so it's valid in our process context.

         DuplicateHandle hProcess, HandleInfo(n).Handle, GetCurrentProcess, hHandle, 0, 0, DUPLICATE_SAME_ACCESS

     ' Checksum
         If hHandle <> 0 Then
     ' Get DOS path,filename and process name.
           szName = GetObjectName(hHandle)
           szAppName = GetProcessName(hProcess)
     ' // TODO: SOME FILTERING GOES HERE. if szName Like "pewpew" Then return results.
           If LenB(szName) > 0 Then
               If InStr(1, szName, ".tax", vbTextCompare) > 0 Then
                   List1.AddItem "hProcess = " & hProcess
                   List1.AddItem "File = " & szName
                   List1.AddItem "Process = " & szAppName
                   List1.AddItem "handle= " & HandleInfo(n).Handle
                   List1.AddItem HandleInfo(n).ProcessID
   ''                Dim hdup As Long
   ''                Call DuplicateHandle(hProcess, HandleInfo(n).Handle, GetCurrentProcess, hdup, DUPLICATE_SAME_ACCESS, 0, DUPLICATE_CLOSE_SOURCE)
   ''                If hdup > 0 Then
   ''                    CloseHandle (hdup)
   ''                End If
               End If
           End If
       '//
     ' Free handle
           CloseHandle hHandle

         End If
       End If
     Next n

   End Sub
   Private Function GetObjectName(ByVal dwHandle As Long) As String

   ' This method gets a filename from a file handle. Only if the file
   ' in question is atleast one byte. If a file is zero bytes
   ' it can't be mapped and the function fails. Choose to use this method
   ' instead of NtQueryObject because it's more stable and typically if
   ' the file is zero bytes it's used by an application that the user
   ' doesn't care about.

     Dim hFileMap        As Long
     Dim pMem            As Long
     Dim cbLength        As Long
     Dim bName(8192)     As Byte

     ' Create a file mapping in our process.
     hFileMap = CreateFileMappingW(dwHandle, 0, PAGE_READONLY, 0, 1, 0)

     ' Check valid handle
     If hFileMap = 0 Then
       Exit Function
     End If

     ' Map the file into memory
     pMem = MapViewOfFile(hFileMap, FILE_MAP_READ, 0, 0, 1)

     ' Check valid memory pointer to file.
     If pMem = 0 Then
       CloseHandle hFileMap
       Exit Function
     End If

     ' Obtain the name from the mapped file.
     cbLength = GetMappedFileNameW(GetCurrentProcess, pMem, VarPtr(bName(0)), 8192)

     ' Check buffer for valid data.
     If cbLength <> 0 Then
       GetObjectName = Left$(bName, cbLength)
     Else
       GetObjectName = vbNullString
     End If

     ' free handles free mapping
     CloseHandle hFileMap
     UnmapViewOfFile pMem
     ' free memory
     Erase bName

   End Function

   Private Function GetProcessName(ByVal dwProcess As Long) As String

   ' The method obtains the process name associated with the real
   ' process handle.

     Dim bProcess(8192)  As Byte
     Dim cbLength        As Long

     cbLength = GetModuleFileNameExW(dwProcess, 0, VarPtr(bProcess(0)), 8192)

     ' check return buffer length
     If cbLength <> 0 Then
         GetProcessName = Left$(bProcess, cbLength)
       Else
         GetProcessName = vbNullString
     End If

     ' free memory
     Erase bProcess

   End Function


   Private Sub OpenProcessForHandle(ByVal ProcessID As Long)

   ' The method obtains a real process handle that can be used
   ' to get additional information about a process.
   ' If the PID is the same don't open the handle again. Only
   ' open the handle if the PID has changed.

     Dim LastPID   As Long

     If ProcessID <> LastPID Then
     ' free handle
       CloseHandle hProcess
     ' get real process handle.
       hProcess = OpenProcess( _
         PROCESS_ALL_ACCESS, _
         0, _
         ProcessID)
       ' checksum
       LastPID = ProcessID

     End If

   End Sub

   Public Sub SeDebugPrivilege()

   ' The following method gives SE_DEBUG_PRIVS.

       Dim Success     As Long
       Dim hToken      As Long
       Dim TokenPriv   As TOKEN_PRIVILEGES
   ' Do work.
       Success = OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, hToken)
       Success = LookupPrivilegeValueA(vbNullString, SE_PRIVILEGE_NAME, TokenPriv.LuidUDT)
       TokenPriv.PrivilegeCount = 1
       TokenPriv.Attributes = SE_PRIVILEGE_ENABLED
       Success = AdjustTokenPrivileges(hToken, 0, TokenPriv, 0, ByVal 0&, ByVal 0&)
       CloseHandle hToken
   End Sub
   Private Function ReadLong(ByVal Ptr As Long) As Long
   ' Helper function reads 4 bytes from memory address.
     Dim Bogus As Long
     RtlMoveMemory Bogus, ByVal Ptr, 4
     ReadLong = Bogus
   End Function

Please help me.

[edit]Added code blocks[/edit]