VB 卸载USB设备/解锁文件

Question

由于篇幅问题,这次只贴关键代码如果需要完整代码的可以去我的博客上去下载.
地址是: http://blog.csdn.net/chenhui530/archive/2007/12/13/1932917.aspxPublic 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 objIo As IO_STATUS_BLOCK, objFn As FILE_NAME_INFORMATION, objN As NM_INFO
    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
                    '这里如果直接调用NtQueryObject可能会挂起解决方法是用线程去处理当线程处理时间超过一定时间就把它干掉
                    '由于VB对多线程支持很差，其实应该说是对CreateThread支持很差，什么原因不要问我，相信网上也写有不少
                    '文件是关于它的,这里我选择了另一个函数也可以建立线程但是它是建立远程线程的，不过它却很稳定正好解决了
                    '我们这里的问题它就是CreateRemoteThread,^_^还记得我说过它很强大吧~~哈哈。
                    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 objIo As IO_STATUS_BLOCK, objFn As FILE_NAME_INFORMATION, objN As NM_INFO
    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
                    '这里如果直接调用NtQueryObject可能会挂起解决方法是用线程去处理当线程处理时间超过一定时间就把它干掉
                    '由于VB对多线程支持很差，其实应该说是对CreateThread支持很差，什么原因不要问我，相信网上也写有不少
                    '文件是关于它的,这里我选择了另一个函数也可以建立线程但是它是建立远程线程的，不过它却很稳定正好解决了
                    '我们这里的问题它就是CreateRemoteThread,^_^还记得我说过它很强大吧~~哈哈。
                    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

Answer 1

由于篇幅问题,这次只贴关键代码如果需要完整代码的可以去我的博客上去下载.
地址是: http://blog.csdn.net/chenhui530/archive/2007/12/13/1932917.aspxPublic 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 objIo As IO_STATUS_BLOCK, objFn As FILE_NAME_INFORMATION, objN As NM_INFO
    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
                    '这里如果直接调用NtQueryObject可能会挂起解决方法是用线程去处理当线程处理时间超过一定时间就把它干掉
                    '由于VB对多线程支持很差，其实应该说是对CreateThread支持很差，什么原因不要问我，相信网上也写有不少
                    '文件是关于它的,这里我选择了另一个函数也可以建立线程但是它是建立远程线程的，不过它却很稳定正好解决了
                    '我们这里的问题它就是CreateRemoteThread,^_^还记得我说过它很强大吧~~哈哈。
                    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 objIo As IO_STATUS_BLOCK, objFn As FILE_NAME_INFORMATION, objN As NM_INFO
    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
                    '这里如果直接调用NtQueryObject可能会挂起解决方法是用线程去处理当线程处理时间超过一定时间就把它干掉
                    '由于VB对多线程支持很差，其实应该说是对CreateThread支持很差，什么原因不要问我，相信网上也写有不少
                    '文件是关于它的,这里我选择了另一个函数也可以建立线程但是它是建立远程线程的，不过它却很稳定正好解决了
                    '我们这里的问题它就是CreateRemoteThread,^_^还记得我说过它很强大吧~~哈哈。
                    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