| 网站首页 | 业界新闻 | 小组 | 威客 | 人才 | 下载频道 | 博客 | 代码贴 | 在线编程 | 编程论坛
欢迎加入我们,一同切磋技术
用户名:   
 
密 码:  
共有 2054 人关注过本帖, 1 人收藏
标题:VB写文件粉碎机
只看楼主 加入收藏
yuma
Rank: 12Rank: 12Rank: 12
来 自:银河系
等 级:贵宾
威 望:37
帖 子:1934
专家分:3012
注 册:2009-12-22
结帖率:89.13%
收藏(1)
 问题点数:0 回复次数:7 
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 编辑 ]
搜索更多相关主题的帖子: 粉碎机 
2012-08-02 17:37
风吹过b
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:贵宾
威 望:364
帖 子:4947
专家分:30084
注 册:2008-10-15
收藏
得分:0 
看完了核心代码,很好很好。


-------------------------------
ReDim Preserve mydirectory(intresult) '重定义动态数组大小,并保存以前数据
这步会很耗时间
建议这里加以优化。

定义一个 变量,表示当前数组的大小。
定义一个变量,表示当前数组已用大小。
当 已用大小=当前大小时,重定义动态数组大小,每次元素增加 10 个或更多。
需要计算一般情况下平均子目录数,平衡空间、时间的关系。

--------------------------------------
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
1M ,建议使用 1048576 来计算,以便确保整个扇区都被写满。填充时,建议使用随机数据填充,不用 全 0 来填充,以利数据安全。
据说,有设备可以从 覆盖 写掉数据的磁盘里恢复历史数据(恐怖)。
--------------

授人于鱼,不如授人于渔
早已停用QQ了
2012-08-02 18:09
yuma
Rank: 12Rank: 12Rank: 12
来 自:银河系
等 级:贵宾
威 望:37
帖 子:1934
专家分:3012
注 册:2009-12-22
收藏
得分:0 
版主真是个大牛。佩服!

心生万象,万象皆程序!
本人计算机知识网:http://bbs.为防伸手党,本站已停止会员注册。
2012-08-02 18:13
Shui_yue
Rank: 2
等 级:论坛游民
帖 子:22
专家分:43
注 册:2012-5-28
收藏
得分:0 
360粉碎机也有碎不了的,楼主做个万能的哈
2012-08-03 01:27
chuxueooo
Rank: 1
等 级:新手上路
帖 子:4
专家分:0
注 册:2012-8-26
收藏
得分:0 
真的很钦佩
2012-08-26 09:13
邵帅
Rank: 7Rank: 7Rank: 7
等 级:贵宾
威 望:20
帖 子:174
专家分:505
注 册:2012-8-27
收藏
得分:0 
厉害,我也要好好学习……

Figure out what you like. Try to become the best in the world of it.
2012-08-27 15:36
magicboy789
Rank: 1
等 级:新手上路
帖 子:1
专家分:0
注 册:2012-9-1
收藏
得分:0 
360很流氓。。。。。
2012-09-01 02:12
wmpsxf
Rank: 1
等 级:新手上路
帖 子:4
专家分:0
注 册:2013-1-17
收藏
得分:0 
很好
2013-01-17 19:51
快速回复:VB写文件粉碎机
数据加载中...
 
   



关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.041098 second(s), 8 queries.
Copyright©2004-2024, BCCN.NET, All Rights Reserved