Option Explicit
　　Private Sub Command1_Click()

　　Dim strPathName As String

　　strPathName = ""

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

　　If strPathName = "" Then Exit Sub　　

　　On Error GoTo ErrorHandle

　　SetAttr strPathName, vbNormal '此行主要是为了检查文件夹名称的有效性

　　RecurseTree strPathName

　　Label1.Caption = "文件夹" & strPathName & "已经删除！"

　　Exit Sub

　　ErrorHandle:

　　MsgBox "无效的文件夹名称:" & 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

作者：佚名 来源：网上转帖