Private Sub Command1_Click()
Dim i As Integer, z As Integer
Dim path As String 'path用于保存filename中的路径信息
cdlg.Flags = cdlOFNAllowMultiselect + cdlOFNExplorer '设置通用对话框可以多选
cdlg.FileName = "" '清空filename中原来的内容
cdlg.Filter = "all files|*,*" '设置公共对话框的文件过滤器
cdlg.ShowOpen '显示“打开”对话框
If cdlg.FileName = "" Then Exit Sub '如果一个文件也没选则退出过程
cdlg.FileName = cdlg.FileName & Chr(0) '在返回filename后增加一个空格以便分离多个文件
z = 1
i = InStr(z, cdlg.FileName, Chr(0)) '查找filename中空格的位置，如果只选择一个文件则直接加入列表框中，选择了多个文件则分离出每个文件并分别加入到列表框中
If i = Len(cdlg.FileName) Then '只有一个文件的情况
List1.AddltemRTrim (cdlg.FileName) '去掉文件名后的空格
Else
path = Mid(cdlg.FileName, z, i - 1) '分离出filename中的路径
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.Addltempath Mid(cdlg.FileName, z, i一1) '将路径加到每个文件前面
z = i + 1
Next
End If
Command3.Enabled = True
End Sub
'SHB rowseForFolder函数返回值是指向项目(ITEM)的一个指针，有了这个数值，再用API函数SHGetPathFromlDList可以获得具体的路径，如果用户按的是“取消”按钮，则返回值为NULL．
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowselnfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByValpidl As Long, pszPath As String) As Long
Private TypeBROWSEINFO
hOwner As Long '当前窗口的句柄
pidlRoot As Long '从何根路径开始展开文件夹，缺省情况,下从“桌面”开始展开．
pszDisplayName As String
IpszTitle AsString '目录树上方的标题，用来给用户一些提示信息．
ulFlage As Long '显示标志控制项：比如若赋值为BIF__BROWSEFORCOMPUTER，则只有当用户选择‘我的电脑”时“确定”按钮才有效，这里我们需要的是BIF_ RETURNONLYFSDlRS，只有用户选择的是文件夹时“确定”按钮才有效．
Ipfn As Long
Iparam As Long
ilmage As Long
End Type
Private Function ShowDir(MehWnd As Long, dirpath As String, Optional Title As String = "请选择文件夹:", Optional flage As Long = &H1, Optional DirlD As Long) As String
Dim Bl As BROWSEINFO
Dim TemplD As Long
Dim TempStr As String
TempStr = String$(255, Chr$(0))
With B1
.hOwner = MehWnd '句柄
.pidlRoot = 0 '展开根目录
.IpszTitle = Title + Chr$(0) '列表框标题
.ulFlage = flage
End With
TemplD = SHBrowseForFolder(B1) '调用API函数显示列表框
DirlD = TemplD
If SHGetPathFromlDList(BvValTemplD, ByVaITempStr) 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 Function '如果文件夹为空则无需遍历
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.Addltem mypath & myname '如果是文件则加入到列表框
End If
End If
myname = Dir '查找下一个目录．
Loop
i = i + 1
Loop
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()
Dim i As Integer, j As Integer
Dim filenumber As Integer
Dim filesize As Long
If List1.ListCount = 0 Then Exit Sub '若列表空则推出
i = MsgBox("执行粉碎后将无法恢复，继续吗?", 33, 文件粉碎) '粉碎前警告用户
If i = 2 Then ExitSub '如果用户选择“否”则退出
For i = O To List1.ListCount - 1
SetAttrList1.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 '如果文件大小为0，则直接删除，粉碎下一个文件;设置进度条的最大和最小值
jdt.Max = filesize
jdt Min = 0
If filesize <= 1000000 Then
Put #filenumber, , String$(filesize, Chr$(0)) '小于1 MB的文件按实际大小一次性填充
jdt.Value = filesize
Else '大于1 MB的文件一次填充1 MB，剩余的按实际大小填充
For j = 1 To filesize \ 1000000
Put #filenumber, , String(1000000, Chr$(0)) '以1MB大的空格字符串进行填充
jdt.Value = jdt.Value + 1000000 '修改进度条的当前值
Next j
Put #filenumber, , String(filesize Mod 1000000, Chr$(0))
jdt.Value = filesize
Endlf
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.Removeltem List1.Listlndex
End Sub
