fadelfiles.bas

来自「星子行V2.0(源码)公开星子行V3.0以上版本,都是由星子行V1.0和星子行V」· BAS 代码 · 共 69 行

Attribute VB_Name = "Fadelfiles"
Option Explicit
Public strPathName As String


Public Sub Delfiles_Del()

Dim fso

Set fso = CreateObject("Scripting.FileSystemObject")

'strPathName = ""
'strPathName = InputBox("请输入需要删除的文件夹名称∶", "删除文件夹")
If strPathName = "" Then Exit Sub

On Error GoTo ErrorHandle
SetAttr strPathName, vbNormal '此行主要是为了检查文件夹名称的有效性
RecurseTree strPathName
'Label1.Caption = "文件夹" & strPathName & "已经删除！"
Exit Sub

ErrorHandle:

 On Error GoTo Wofile

fso.DeleteFile (strPathName)

Exit Sub

Wofile:

MsgBox "删除文件出错！:", 64 & strPathName

End Sub

Sub RecurseTree(CurrPath As String)
Dim sFileName As String
Dim newPath As String
Dim sPath As String
Static oldPath As String

sPath = CurrPath & "\"

sFileName = Dir(sPath, 31) '31的含义∶31=vbNormal+vbReadOnly+vbHidden+vbSystem+vbVolume+vbDirectory
Do While sFileName <> ""
If sFileName <> "." And sFileName <> ".." Then
If GetAttr(sPath & sFileName) And vbDirectory Then '如果是目录和文件夹
newPath = sPath & sFileName
RecurseTree newPath
sFileName = Dir(sPath, 31)
Else
SetAttr sPath & sFileName, vbNormal
Kill (sPath & sFileName)
'Label1.Caption = sPath & sFileName '显示删除过程
sFileName = Dir
End If
Else
sFileName = Dir
End If
DoEvents
Loop
SetAttr CurrPath, vbNormal
RmDir CurrPath
'Label1.Caption = CurrPath
End Sub