VB写文件粉碎机
呵呵，没有360文件粉碎机强大。
VB 文件粉碎机源代码.rar
(4.48 KB)
程序代码：
' 此函数返回值是指向项目（ITEM）的一个指针，有了这个数值，再用API函数SHGetPathFromIDList可以获得具体的路径，如果用户按的是“取消”按钮，则返回值为NULL。
Private Declare Function SHBrowseForFolder _
Lib "shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList _
Lib "shell32.dll" _
(ByVal pidl As Long, _
pszPath As String) As Long
Private Type BROWSEINFO
hOwner As Long ' 当前窗口的句柄。
pidlRoot As Long ' 从何根路径开始展开文件夹，缺省情况下从“桌面”开始展开。
pszDisplayName As String
lpszTitle As String ' 目录树上方的标题，用来给用户一些提示信息。
ulFlage As Long ' 显示标志控制项：比如若赋值为BIF_BROWSEFORCOMPUTER，则只有当用户选择“我的电脑”时“确定”按钮才有效，这里我们需要的是 BIF_RETURNONLYFSDIRS，只有用户选择的是文件夹时“确定”按钮才有效。
lpfn As Long
lparam As Long
iImage As Long
End Type
Private Function ShowDir(MehWnd As Long, _
dirpath As String, _
Optional Title As String = "请选择文件夹：", _
Optional flage As Long = &H1, _
Optional DirID As Long) As String
Dim BI As BROWSEINFO
Dim TempID As Long
Dim TempStr As String
TempStr = String$(255, Chr$(0))
With BI
.hOwner = MehWnd '句柄
.pidlRoot = 0 '展开根目录
.lpszTitle = Title + Chr$(0) '列表框标题
.ulFlage = flage
End With
TempID = SHBrowseForFolder(BI) '调用API函数显示列表框
DirID = TempID
If SHGetPathFromIDList(ByVal TempID, ByVal TempStr) Then
dirpath = Left$(TempStr, InStr(TempStr, Chr$(0)) - 1)
ShowDir = dirpath
Else
ShowDir = ""
End If
End Function
Sub Findfile(getPath As String) '遍历目录里的所有文件
Dim mypath As String
Dim myname As String
Dim mydirectory() As String
Dim i, intresult As Integer
mypath = getPath
If mypath = "" Then Exit Sub '如果文件夹为空则无需遍历
intresult = 2
ReDim mydirectory(intresult) '初始化动态数组
mydirectory(1) = mypath
i = 1
Do Until mydirectory(i) = "" '以广度优先算法遍历目录
mypath = mydirectory(i)
If Right(mypath, 1) <> "\" Then mypath = mypath & "\"
myname = Dir(mypath, vbDirectory) ' 找寻第一项。
Do While myname <> "" ' 开始循环。
If myname <> "." And myname <> ".." Then ' 跳过当前的目录及上层目录。
If (GetAttr(mypath & myname) And vbDirectory) = vbDirectory Then ' 使用位比较来确定 MyName 代表一目录。
mydirectory(intresult) = mypath & myname ' 如果它是一个目录，将其名称存储在一个数组里。
intresult = intresult + 1
ReDim Preserve mydirectory(intresult) '重定义动态数组大小，并保存以前数据
Else
List1.AddItem mypath & myname '如果是文件则加入到列表框
End If
End If
myname = Dir ' 查找下一个目录。
Loop
i = i + 1
Loop
End Sub
Private Sub Command1_Click() '添加文件
Dim i As Integer, z As Integer
Dim path As String
cdlg.Flags = cdlOFNAllowMultiselect + cdlOFNExplorer '设置通用对话框可以多选
cdlg.FileName = ""
cdlg.Filter = "All Files|*.*" '设置公共对话框的文件过滤器
cdlg.ShowOpen '显示“打开”对话框
If cdlg.FileName = "" Then Exit Sub '如果一个文件也没选则退出过程
cdlg.FileName = cdlg.FileName & Chr(0)
z = 1
i = InStr(z, cdlg.FileName, Chr(0))
'选择一个文件则直接加入列表框中，如果选择多个文件则分离出每个文件分别加入列表框。
If i = Len(cdlg.FileName) Then
List1.AddItem RTrim(cdlg.FileName)
Else
path = Mid(cdlg.FileName, z, i - 1)
z = i + 1
If Right(path, 1) <> "\" Then path = path + "\"
For i = z To Len(cdlg.FileName)
i = InStr(z, cdlg.FileName, Chr(0))
List1.AddItem path + Mid(cdlg.FileName, z, i - 1)
z = i + 1
Next
End If
Command3.Enabled = True
End Sub
Private Sub Command2_Click() '添加目录
Dim mypath As String
mypath = ShowDir(Me.hWnd, App.path) '调用函数选择目录
Findfile mypath '调用函数遍历目录
Command3.Enabled = True
End Sub
Private Sub Command3_Click() '开始粉碎
If List1.ListCount = 0 Then Exit Sub '如果列表框空则不用执行
Dim i As Integer, j As Integer
Dim filenumber As Integer
Dim filesize As Long
i = MsgBox("执行粉碎后将无法恢复，继续吗？", 33, "文件粉碎")
If i = 2 Then Exit Sub
For i = 0 To List1.ListCount - 1
SetAttr List1.List(i), vbNormal '将所有文件属性设置为普通文件，因为只读文件是无法写入的
Next i
For i = 0 To List1.ListCount - 1
filenumber = FreeFile '获取可用文件号
Open List1.List(i) For Binary As #filenumber '以Binary方式打开文件
filesize = LOF(filenumber)
If filesize = 0 Then GoTo continue
'设置进度条的最大和最小值
jdt.Max = filesize
jdt.Min = 0
If filesize <= 1000000 Then
Put #filenumber, , String$(filesize, Chr$(0)) '小于1M的文件按实际大小一次性填充
jdt.Value = filesize
Else
'大于1M的文件一次填充1M，剩余的按实际大小填充
For j = 1 To filesize \ 1000000
Put #filenumber, , String(1000000, Chr$(0))
jdt.Value = jdt.Value + 1000000
Next j
Put #filenumber, , String(filesize Mod 1000000, Chr$(0))
jdt.Value = filesize
End If
jdt.Value = 0
continue: Close filenumber
Kill List1.List(i) '粉碎结束一个文件后将其删除
Next i
MsgBox "完成文件粉碎！"
List1.Clear
Command3.Enabled = False
End Sub
Private Sub Command4_Click() '清空列表
List1.Clear
End Sub
Private Sub Command5_Click() '退出系统
End
End Sub
Private Sub Form_Load()
Command3.Enabled = False
End Sub
Private Sub List1_DblClick()
List1.RemoveItem List1.ListIndex
End Sub
[ 本帖最后由 yuma 于 2012-8-2 17:38 编辑 ]
）。
