'此函数返回值是指向项目(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