VB设置文件占坑防止被删除

mengl520

Option Explicit
'=========================================================================================
'//功能:文件占坑防止被删
'//用法:
'Sub Main()
'        Dim strPath As String
'        strPath = App.Path
'        If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
'        Debug.Print DupFile(strPath & App.EXEName & ".exe")
'End Sub
'==========================================================================================
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessID As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function DuplicateHandle Lib "kernel32" (ByVal hSourceProcessHandle As Long, ByVal hSourceHandle As Long, ByVal hTargetProcessHandle As Long, lpTargetHandle As Long, ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwOptions As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_SHARE_WRITE = &H2
Private Const FILE_SHARE_READ = &H1
Private Const OPEN_ALWAYS = 4
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Boolean
End Type
Private Const PROCESS_DUP_HANDLE As Long = &H40
Private Const INVALID_HANDLE_VALUE = -1
Private Const DUPLICATE_SAME_ACCESS = &H2
Private Const DUPLICATE_CLOSE_SOURCE = &H1
Dim xxNull As SECURITY_ATTRIBUTES
Public Function DupFile(lpFileName As String) As Boolean
    Dim bRedup As Boolean
    Dim hFile As Long, hProcess As Long
    Dim hTargetHandle As Long
    Call RtlAdjustPrivilege(20)
    hProcess = LzOpenProcess(PROCESS_DUP_HANDLE, 4)
    If hProcess = 0 Then
        Debug.Print "PROCESS_DUP_HANDLE Error"
        DupFile = False
        Exit Function
    End If
    hFile = CreateFile(lpFileName, GENERIC_READ, 0, xxNull, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
    If (hFile = INVALID_HANDLE_VALUE) Then
        Debug.Print "CreateFile Error"
        CloseHandle hProcess
        DupFile = False
        Exit Function
    End If
    bRedup = DuplicateHandle(GetCurrentProcess(), hFile, hProcess, VarPtr(hTargetHandle), 0, False, DUPLICATE_SAME_ACCESS Or DUPLICATE_CLOSE_SOURCE)
    CloseHandle hProcess
    DupFile = bRedup
End Function