VB文件粉碎机

 

'代码:Option Explicit'======================用于查找进程和终止进程的API函数常数定义================ =====Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, ByVal lProcessID As Long) As LongPrivate Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As LongPrivate Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As LongPrivate Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As LongPrivate Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPrivate Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As LongConst MAX_PATH As Integer = 260Private 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_PATHEnd TypeConst TH32CS_SNAPheaplist = &H1Const TH32CS_SNAPPROCESS = &H2Const TH32CS_SNAPthread = &H4Const TH32CS_SNAPmodule = &H8Const TH32CS_SNAPall = TH32CS_SNAPPROCESS + TH32CS_SNAPheaplist + TH32CS_SNAPthread + TH32CS_SNAPmodule'======================在WIN2000下提升本进程权限的API函数常数定义=========== ==========Const STANDARD_RIGHTS_REQUIRED = &HF0000Const TOKEN_ASSIGN_PRIMARY = &H1Const TOKEN_DUPLICATE = (&H2)Const TOKEN_IMPERSONATE = (&H4)Const TOKEN_QUERY = (&H8)Const TOKEN_QUERY_SOURCE = (&H10)Const TOKEN_ADJUST_PRIVILEGES = (&H20)Const TOKEN_ADJUST_GROUPS = (&H40)Const TOKEN_ADJUST_DEFAULT = (&H80)Const TOKEN_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or TOKEN_ASSIGN_PRIMARY Or _ TOKEN_DUPLICATE Or TOKEN_IMPERSONATE Or TOKEN_QUERY Or TOKEN_QUERY_SOURCE Or _ TOKEN_ADJUST_PRIVILEGES Or TOKEN_ADJUST_GROUPS Or TOKEN_ADJUST_DEFAULT)Const SE_PRIVILEGE_ENABLED = &H2Const ANYSIZE_ARRAY = 1Private Type LUID lowpart As Long highpart As LongEnd TypePrivate Type LUID_AND_ATTRIBUTES pLuid As LUID Attributes As LongEnd TypePrivate Type TOKEN_PRIVILEGES PrivilegeCount As Long Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTESEnd TypePrivate Declare Function GetCurrentProcess Lib "kernel32" () As LongPrivate Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As LongPrivate Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As LongPrivate Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As LongPrivate Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesA" (ByVal lpFileName As String, ByVal dwFileAttributes As Long) As LongDim i As Long, lPid As LongDim Proc As PROCESSENTRY32Dim hSnapShot As LongDim lPHand As Long, TMBack As LongPrivate Sub Command1_Click() On Error GoTo errha If ListView1.Visible = True Then If ListView1.SelectedItem.Text <> "" Then lPHand = Val(ListView1.SelectedItem.Text) lPHand = OpenProcess(1&, True, lPHand) '获取进程句柄 TMBack = TerminateProcess(lPHand, 0&) '关闭进程 If TMBack <> 0 Then MsgBox ListView1.SelectedItem.SubItems(1) & "已经被终止！" Else MsgBox ListView1.SelectedItem.SubItems(1) & "不能被终止！" End If CloseHandle lPHand End If End If If Text1.Text <> "" Then Fensuiwenjian End If Exit Suberrha: MsgBox "unknow error!!!", vbInformation, "文件刪除"End SubPrivate Sub Command2_Click() C1.ShowOpen If C1.FileName <> "" Then Text1.Text = C1.FileName Label2.Caption = FileLen(Text1.Text) & " Bytes" End IfEnd SubPrivate Sub KillProcess(ByVal strProcess As String) Dim strComputer As String Dim objWMIService As Object Dim colProcessList Dim objProcess As Object On Error Resume Next strComputer = "." Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!//" & strComputer & "/root/cimv2") Set colProcessList = objWMIService.ExecQuery("Select * from Win32_Process Where Name = '" & strProcess & "'") For Each objProcess In colProcessList objProcess.Terminate NextEnd SubPrivate Sub Command3_Click() If Command3.Caption = "无进程操作" Then ListView1.Visible = False Command3.Caption = "有进程操作" Else ListView1.Visible = True Command3.Caption = "无进程操作" End IfEnd SubPrivate Sub Command4_Click() ListView1.ListItems.Clear '清空ListView hSnapShot = CreateToolhelpSnapshot(TH32CS_SNAPall, 0) '获得进程“快照”的句柄 Proc.dwSize = Len(Proc) lPid = ProcessFirst(hSnapShot, Proc) '获取第一个进程的PROCESSENTRY32结构信息数据 i = 0 Do While lPid <> 0 '当返回值非零时继续获取下一个进程 ListView1.ListItems.Add , "a" & i, Proc.th32ProcessID & "(&H" & Hex(Proc.th32ProcessID) & ")" '将进程ID添加到ListView1第一列 ListView1.ListItems("a" & i).SubItems(1) = Proc.szExeFile '将进程名添加到ListView1第二列 i = i + 1 lPid = ProcessNext(hSnapShot, Proc) '循环获取下一个进程的PROCESSENTRY32结构信息数据 Loop CloseHandle hSnapShot '关闭进程“快照”句柄End SubPrivate Sub Command5_Click()If Command5.Caption = "自动刷新进程" ThenTimer1.Enabled = TrueCommand5.Caption = "取消自动刷新"ElseTimer1.Enabled = FalseCommand5.Caption = "自动刷新进程"End IfEnd SubPrivate Sub Form_Load() AdjustTokenPrivileges2000 ListView1.ColumnHeaders.Clear ListView1.ColumnHeaders.Add , "a", "进程ID", 800 ListView1.ColumnHeaders.Add , "b", "进程名", 4900 ListView1.View = lvwReportEnd SubPrivate Sub Fensuiwenjian() Dim buff() As Byte ProgressBar1.Visible = True Dim filelong As Long ProgressBar1.Min = 0 Open Text1.Text For Binary Access Read Write As #1 ReDim buff(1 To 2560) filelong = LOF(1) ProgressBar1.Max = filelong ProgressBar1.Value = 0 Do While Not EOF(1) Get #1, , buff For i = 1 To 2560 buff(i) = 255 'Debug.Print "buff" & i & "=" & buff(i) Next i For i = 1 To filelong Step 2560 Put #1, i, buff ProgressBar1.Value = i Next i Loop Close #1 Dim fso As New FileSystemObject fso.DeleteFile Text1.Text, True Text1.Text = "" MsgBox "文件删除成功！", vbOKOnly ProgressBar1.Visible = FalseEnd Sub'这个函数用于在WIN2000系统中，本进程提升权限Sub AdjustTokenPrivileges2000() Dim hdlProcessHandle As Long Dim hdlTokenHandle As Long Dim tmpLuid As LUID Dim tkp As TOKEN_PRIVILEGES Dim tkpNewButIgnored As TOKEN_PRIVILEGES Dim lBufferNeeded As Long Dim lP As Long hdlProcessHandle = GetCurrentProcess() lP = OpenProcessToken(hdlProcessHandle, TOKEN_ALL_ACCESS, hdlTokenHandle) lP = LookupPrivilegeValue("", "SeDebugPrivilege", tmpLuid) tkp.PrivilegeCount = 1 tkp.Privileges(0).pLuid = tmpLuid tkp.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED lP = AdjustTokenPrivileges(hdlTokenHandle, False, tkp, Len(tkpNewButIgnored), tkpNewButIgnored, lBufferNeeded)End SubPrivate Sub Timer1_Timer() ListView1.ListItems.Clear '清空ListView hSnapShot = CreateToolhelpSnapshot(TH32CS_SNAPall, 0) '获得进程“快照”的句柄 Proc.dwSize = Len(Proc) lPid = ProcessFirst(hSnapShot, Proc) '获取第一个进程的PROCESSENTRY32结构信息数据 i = 0 Do While lPid <> 0 '当返回值非零时继续获取下一个进程 ListView1.ListItems.Add , "a" & i, Proc.th32ProcessID & "(&H" & Hex(Proc.th32ProcessID) & ")" '将进程ID添加到ListView1第一列 ListView1.ListItems("a" & i).SubItems(1) = Proc.szExeFile '将进程名添加到ListView1第二列 i = i + 1 lPid = ProcessNext(hSnapShot, Proc) '循环获取下一个进程的PROCESSENTRY32结构信息数据 Loop CloseHandle hSnapShot '关闭进程“快照”句柄End Sub

 

http://hi.baidu.com/yzidan/blog/item/f313bdf314328453352acca8.html