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 编辑 ]