modlockfileinfo.bas

卸载USB设备的软件

Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcpyW Lib "kernel32" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Public Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
Private Declare Function CreateRemoteThread Lib "kernel32" (ByVal hProcess As Long, lpThreadAttributes As Any, ByVal dwStackSize As Long, lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lpExitCode As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function TerminateThread Lib "kernel32" (ByVal hThread As Long, ByVal dwExitCode As Long) As Long
Private Declare Function GetFileType Lib "kernel32" (ByVal hFile As Long) As Long
Private Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long

Private Function NT_SUCCESS(ByVal nStatus As Long) As Boolean
    NT_SUCCESS = (nStatus >= 0)
End Function

Public Function GetFileFullPath(ByVal hFile As Long) As String
    Dim hHeap As Long, dwSize As Long, objName As UNICODE_STRING, pName As Long
    Dim ntStatus As Long, i As Long, lngNameSize As Long, strDrives As String, strArray() As String
    Dim dwDriversSize As Long, strDrive As String, strTmp As String, strTemp As String
    On Error GoTo ErrHandle
    hHeap = GetProcessHeap
    pName = HeapAlloc(hHeap, HEAP_ZERO_MEMORY, &H1000)
    ntStatus = NtQueryObject(hFile, ObjectNameInformation, pName, &H1000, dwSize)
    If (NT_SUCCESS(ntStatus)) Then
        i = 1
        Do While (ntStatus = STATUS_INFO_LEN_MISMATCH)
            pName = HeapReAlloc(hHeap, HEAP_ZERO_MEMORY, pName, &H1000 * i)
            ntStatus = NtQueryObject(hFile, ObjectNameInformation, pName, &H1000, ByVal 0)
            i = i + 1
        Loop
    End If
    HeapFree hHeap, 0, pName
    strTemp = String(512, Chr(0))
    lstrcpyW strTemp, pName + Len(objName)
    strTemp = StrConv(strTemp, vbFromUnicode)
    strTemp = Left(strTemp, InStr(strTemp, Chr(0)) - 1)
    strDrives = String(512, Chr(9))
    dwDriversSize = GetLogicalDriveStrings(512, strDrives)
    If dwDriversSize Then
        strArray = Split(strDrives, Chr(0))
        For i = 0 To UBound(strArray)
            If strArray(i) <> "" Then
                strDrive = Left(strArray(i), 2)
                strTmp = String(260, Chr(0))
                Call QueryDosDevice(strDrive, strTmp, 256)
                strTmp = Left(strTmp, InStr(strTmp, Chr(0)) - 1)
                If InStr(LCase(strTemp), LCase(strTmp)) = 1 Then
                    GetFileFullPath = strDrive & Mid(strTemp, Len(strTmp) + 1, Len(strTemp) - Len(strTmp))
                    Exit Function
                End If
            End If
        Next
    End If
ErrHandle:
End Function

Public Function CloseLockFileHandle(ByVal strFileName As String, ByVal dwProcessId As Long) As Boolean
    Dim ntStatus As Long
    Dim objCid As CLIENT_ID
    Dim objOa As OBJECT_ATTRIBUTES
    Dim lngHandles As Long
    Dim i As Long
    Dim objInfo As SYSTEM_HANDLE_INFORMATION, lngType As Long
    Dim hProcess As Long, hProcessToDup As Long, hFileHandle As Long
    Dim hFile As Long
    Dim bytBytes() As Byte, strSubPath As String, strTmp As String
    Dim blnIsOk As Boolean
    strSubPath = Mid(strFileName, 3, Len(strFileName) - 2)
    hFile = CreateFile("NUL", &H80000000, 0, ByVal 0&, 3, 0, 0)
    If hFile = -1 Then
        CloseLockFileHandle = False
        Exit Function
    End If
    objOa.Length = Len(objOa)
    objCid.UniqueProcess = dwProcessId
    ntStatus = 0
    Dim bytBuf() As Byte
    Dim nSize As Long
    nSize = 1
    Do
        ReDim bytBuf(nSize)
        ntStatus = NtQuerySystemInformation(SystemHandleInformation, VarPtr(bytBuf(0)), nSize, 0&)
        If (Not NT_SUCCESS(ntStatus)) Then
            If (ntStatus <> STATUS_INFO_LENGTH_MISMATCH) Then
                Erase bytBuf
                Exit Function
            End If
        Else
            Exit Do
        End If
        nSize = nSize * 2
        ReDim bytBuf(nSize)
    Loop
    lngHandles = 0
    CopyMemory objInfo.uCount, bytBuf(0), 4
    lngHandles = objInfo.uCount
    ReDim objInfo.aSH(lngHandles - 1)
    Call CopyMemory(objInfo.aSH(0), bytBuf(4), Len(objInfo.aSH(0)) * lngHandles)
    For i = 0 To lngHandles - 1
        If objInfo.aSH(i).HandleValue = hFile And objInfo.aSH(i).UniqueProcessId = GetCurrentProcessId Then
            lngType = objInfo.aSH(i).ObjectTypeIndex
            Exit For
        End If
    Next
    NtClose hFile
    blnIsOk = True
    For i = 0 To lngHandles - 1
        If objInfo.aSH(i).ObjectTypeIndex = lngType And objInfo.aSH(i).UniqueProcessId = dwProcessId Then
            ntStatus = NtOpenProcess(hProcessToDup, PROCESS_DUP_HANDLE, objOa, objCid)
            If hProcessToDup <> 0 Then
                ntStatus = NtDuplicateObject(hProcessToDup, objInfo.aSH(i).HandleValue, GetCurrentProcess, hFileHandle, 0, 0, DUPLICATE_SAME_ATTRIBUTES)
                If (NT_SUCCESS(ntStatus)) Then
                    ntStatus = MyGetFileType(hFileHandle)
                    If ntStatus Then
                        strTmp = GetFileFullPath(hFileHandle)
                    End If
                    NtClose hFileHandle
                    If InStr(LCase(strTmp), LCase(strFileName)) Then
                        If Not CloseRemoteHandle(dwProcessId, objInfo.aSH(i).HandleValue, strFileName) Then
                            blnIsOk = False
                        End If
                    End If
                End If
            End If
        End If
    Next
    CloseLockFileHandle = blnIsOk
End Function
Public Function CloseLoackFiles(ByVal strFileName As String) As Boolean
    Dim ntStatus As Long
    Dim objCid As CLIENT_ID
    Dim objOa As OBJECT_ATTRIBUTES
    Dim lngHandles As Long
    Dim i As Long
    Dim objInfo As SYSTEM_HANDLE_INFORMATION, lngType As Long
    Dim hProcess As Long, hProcessToDup As Long, hFileHandle As Long
    Dim hFile As Long, blnIsOk As Boolean, strProcessName As String
    Dim bytBytes() As Byte, strSubPath As String, strTmp As String
    strSubPath = Mid(strFileName, 3, Len(strFileName) - 2)
    hFile = CreateFile("NUL", &H80000000, 0, ByVal 0&, 3, 0, 0)
    If hFile = -1 Then
        CloseLoackFiles = False
        Exit Function
    End If
    objOa.Length = Len(objOa)
    ntStatus = 0
    Dim bytBuf() As Byte
    Dim nSize As Long
    nSize = 1
    Do
        ReDim bytBuf(nSize)
        ntStatus = NtQuerySystemInformation(SystemHandleInformation, VarPtr(bytBuf(0)), nSize, 0&)
        If (Not NT_SUCCESS(ntStatus)) Then
            If (ntStatus <> STATUS_INFO_LENGTH_MISMATCH) Then
                Erase bytBuf
                Exit Function
            End If
        Else
            Exit Do
        End If
        nSize = nSize * 2
        ReDim bytBuf(nSize)
    Loop
    lngHandles = 0
    CopyMemory objInfo.uCount, bytBuf(0), 4
    lngHandles = objInfo.uCount
    ReDim objInfo.aSH(lngHandles - 1)
    Call CopyMemory(objInfo.aSH(0), bytBuf(4), Len(objInfo.aSH(0)) * lngHandles)
    For i = 0 To lngHandles - 1
        If objInfo.aSH(i).HandleValue = hFile And objInfo.aSH(i).UniqueProcessId = GetCurrentProcessId Then
            lngType = objInfo.aSH(i).ObjectTypeIndex
            Exit For
        End If
    Next
    NtClose hFile
    blnIsOk = True
    For i = 0 To lngHandles - 1
        If objInfo.aSH(i).ObjectTypeIndex = lngType Then
            objCid.UniqueProcess = objInfo.aSH(i).UniqueProcessId
            ntStatus = NtOpenProcess(hProcessToDup, PROCESS_DUP_HANDLE, objOa, objCid)
            If hProcessToDup <> 0 Then
                ntStatus = NtDuplicateObject(hProcessToDup, objInfo.aSH(i).HandleValue, GetCurrentProcess, hFileHandle, 0, 0, DUPLICATE_SAME_ATTRIBUTES)
                If (NT_SUCCESS(ntStatus)) Then
                    ntStatus = MyGetFileType(hFileHandle)
                    If ntStatus Then
                        strTmp = GetFileFullPath(hFileHandle)
                    Else
                        strTmp = ""
                    End If
                    NtClose hFileHandle
                    If InStr(LCase(strTmp), LCase(strFileName)) Then
                        If Not CloseRemoteHandle(objInfo.aSH(i).UniqueProcessId, objInfo.aSH(i).HandleValue, strTmp) Then
                            blnIsOk = False
                        End If
                    End If
                End If
            End If
        End If
    Next
    CloseLoackFiles = blnIsOk
End Function

Private Function GetProcessCommandLine(ByVal dwProcessId As Long) As String
    Dim objCid As CLIENT_ID
    Dim objOa As OBJECT_ATTRIBUTES
    Dim ntStatus As Long, hKernel As Long, strName As String
    Dim hProcess As Long, dwAddr As Long, dwRead As Long
    objOa.Length = Len(objOa)
    objCid.UniqueProcess = dwProcessId
    ntStatus = NtOpenProcess(hProcess, &H10, objOa, objCid)
    If hProcess = 0 Then
        GetProcessCommandLine = ""
        Exit Function
    End If
    hKernel = GetModuleHandle("kernel32")
    dwAddr = GetProcAddress(hKernel, "GetCommandLineA")
    CopyMemory dwAddr, ByVal dwAddr + 1, 4
    If ReadProcessMemory(hProcess, ByVal dwAddr, dwAddr, 4, dwRead) Then
        strName = String(260, Chr(0))
        If ReadProcessMemory(hProcess, ByVal dwAddr, ByVal strName, 260, dwRead) Then
            strName = Left(strName, InStr(strName, Chr(0)) - 1)
            NtClose hProcess
            GetProcessCommandLine = strName
            Exit Function
        End If
    End If
    NtClose hProcess
End Function
Public Function CloseRemoteHandle(ByVal dwProcessId, ByVal hHandle As Long, Optional ByVal strLockFile As String = "") As Boolean
    Dim hMyProcess  As Long, hRemProcess As Long, blnResult As Long, hMyHandle As Long
    Dim objCid As CLIENT_ID
    Dim objOa As OBJECT_ATTRIBUTES
    Dim ntStatus As Long, strProcessName As String, hProcess As Long, strMsg As String
    objCid.UniqueProcess = dwProcessId
    objOa.Length = Len(objOa)
    hMyProcess = GetCurrentProcess()
    ntStatus = NtOpenProcess(hRemProcess, PROCESS_DUP_HANDLE, objOa, objCid)
    If hRemProcess Then
        ntStatus = NtDuplicateObject(hRemProcess, hHandle, GetCurrentProcess, hMyHandle, 0, 0, DUPLICATE_CLOSE_SOURCE Or DUPLICATE_SAME_ACCESS)
        If (NT_SUCCESS(ntStatus)) Then
        'If DuplicateHandle(hRemProcess, hMyProcess, hHandle, hMyHandle, 0, 0, DUPLICATE_CLOSE_SOURCE Or DUPLICATE_SAME_ACCESS) Then
            blnResult = NtClose(hMyHandle)
            If blnResult >= 0 Then
                strProcessName = GetProcessCommandLine(dwProcessId)
                'If InStr(LCase(strProcessName), LCase(strLockFile)) Then
                If InStr(LCase(strProcessName), "explorer.exe") = 0 And dwProcessId <> GetCurrentProcessId Then
                    objCid.UniqueProcess = dwProcessId
                    ntStatus = NtOpenProcess(hProcess, 1, objOa, objCid)
                    If hProcess <> 0 Then TerminateProcess hProcess, 0
                End If
            End If
        End If
        Call NtClose(hRemProcess)
    End If
    CloseRemoteHandle = blnResult >= 0
End Function
Public Function CloseRemoteHandleEx(ByVal dwProcessId, ByVal hHandle As Long, Optional ByVal strLockFile As String = "") As Boolean
    Dim hRemProcess As Long, hThread As Long, lngResult As Long, pfnThreadRtn As Long, hKernel As Long
    Dim objCid As CLIENT_ID
    Dim objOa As OBJECT_ATTRIBUTES, strMsg As String
    Dim ntStatus As Long, strProcessName As String, hProcess As Long
    objCid.UniqueProcess = dwProcessId
    objOa.Length = Len(objOa)
    ntStatus = NtOpenProcess(hRemProcess, PROCESS_QUERY_INFORMATION Or PROCESS_CREATE_THREAD Or PROCESS_VM_OPERATION Or PROCESS_VM_WRITE, objOa, objCid)
'    hMyProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_CREATE_THREAD Or PROCESS_VM_OPERATION Or PROCESS_VM_WRITE, 0, dwProcessId)
    If hRemProcess = 0 Then
        CloseRemoteHandleEx = False
        Exit Function
    End If
    hKernel = GetModuleHandle("kernel32")
    If hKernel = 0 Then
        CloseRemoteHandleEx = False
        Exit Function
    End If
    pfnThreadRtn = GetProcAddress(hKernel, "CloseHandle")
    If pfnThreadRtn = 0 Then
        FreeLibrary hKernel
        CloseRemoteHandleEx = False
        Exit Function
    End If
    hThread = CreateRemoteThread(hRemProcess, ByVal 0&, 0&, ByVal pfnThreadRtn, ByVal hHandle, 0, 0&)
    If hThread = 0 Then
        FreeLibrary hKernel
        CloseRemoteHandleEx = False
        Exit Function
    End If
    GetExitCodeThread hThread, lngResult
    CloseRemoteHandleEx = CBool(lngResult)
    strProcessName = GetProcessCommandLine(dwProcessId)
    If InStr(strProcessName, strLockFile) Then
        objCid.UniqueProcess = dwProcessId
        ntStatus = NtOpenProcess(hProcess, 1, objOa, objCid)
        If hProcess <> 0 Then TerminateProcess hProcess, 0
    End If
    NtClose hThread
    NtClose hRemProcess
    FreeLibrary hKernel
End Function

Private Function MyGetFileType(ByVal hFile As Long) As Long
    Dim hRemProcess As Long, hThread As Long, lngResult As Long, pfnThreadRtn As Long, hKernel As Long
    Dim dwEax As Long, dwTimeOut As Long
    hRemProcess = GetCurrentProcess
    hKernel = GetModuleHandle("kernel32")
    If hKernel = 0 Then
        MyGetFileType = 0
        Exit Function
    End If
    pfnThreadRtn = GetProcAddress(hKernel, "GetFileType")
    If pfnThreadRtn = 0 Then
        FreeLibrary hKernel
        MyGetFileType = 0
        Exit Function
    End If
    hThread = CreateRemoteThread(hRemProcess, ByVal 0&, 0&, ByVal pfnThreadRtn, ByVal hFile, 0, ByVal 0&)
    dwEax = WaitForSingleObject(hThread, 100)
    If dwEax = &H102 Then
        Call GetExitCodeThread(hThread, dwTimeOut)
        Call TerminateThread(hThread, dwTimeOut)
        NtClose hThread
        MyGetFileType = 0
        Exit Function
    End If
    If hThread = 0 Then
        FreeLibrary hKernel
        MyGetFileType = False
        Exit Function
    End If
    GetExitCodeThread hThread, lngResult
    MyGetFileType = lngResult
    NtClose hThread
    NtClose hRemProcess
    FreeLibrary hKernel
End Function