求助删除Dir1控件中选中的文件夹的代码

Question

Option ExplicitPrivate Sub Command1_Click()
    If Dir(Dir1.List(Dir1.ListIndex) & "\*.*") = "" Then
        RmDir Dir1.List(Dir1.ListIndex)
        Dir1.Refresh
    End If
End Sub

Answer 1

Option ExplicitPrivate Sub Command1_Click()
    If Dir(Dir1.List(Dir1.ListIndex) & "\*.*") = "" And Dir(Dir1.List(Dir1.ListIndex) & "\*.*", vbDirectory) = "" Then
        RmDir Dir1.List(Dir1.ListIndex)
        Dir1.Refresh
    End If
End Sub

Answer 2

Option ExplicitPrivate Sub Command1_Click()
Dim strDirectory As String    strDirectory = Dir(Dir1.List(Dir1.ListIndex) & "\*.*", vbDirectory)
    If strDirectory > "" Then
        If strDirectory <> "." And strDirectory <> ".." Then
            MsgBox "Subdirectory found in the directory."
            Exit Sub
        End If
        strDirectory = Dir()
    End If
    
    If Dir(Dir1.List(Dir1.ListIndex) & "\*.*") > "" Then
        MsgBox "File(s) found in the directory."
        Exit Sub
    End If
    
    RmDir (Dir1.List(Dir1.ListIndex))
    Dir1.RefreshEnd Sub

Answer 3

还是不行 在删除有下级文件夹是在  RmDir (Dir1.List(Dir1.ListIndex))出错了

Answer 4

如果你不想在这里检测文件夹下的文件：
......
'    If Dir(Dir1.List(Dir1.ListIndex) & "\*.*") > "" Then
'        MsgBox "File(s) found in the directory."
'        Exit Sub
'    End If
    strDirectory = Dir("C:\*.*")    RmDir (Dir1.List(Dir1.ListIndex))
    Dir1.Refresh
......
总之，要关闭打开的目录对象。

Answer 5

谢谢老师，我是完整粘你的代码的，
就是说 RmDir (Dir1.List(Dir1.ListIndex)) 这句代码只能删除空的文件夹 ，你的代码中好象没有判断当前文件夹内有没有下级文件夹的代码 ，所以在执行RmDir (Dir1.List(Dir1.ListIndex))时挂住了

Answer 6

我写成这样
Private Sub Image2_删_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   If Dir1.ListIndex < 0 Then
      MsgBox "     不能删除打开了的文件夹  ！     ", 16, "☆-错误提示"
      Exit Sub
   End If
   If Dir(Dir1.List(Dir1.ListIndex) & "\*.*") > "" Then
      MsgBox "     不能删除内有文件文的件夹  ！     ", 16, "☆-错误提示"
      Exit Sub
   End If
   On Error Resume Next                                '忽略错误开始
   RmDir (Dir1.List(Dir1.ListIndex))
   If Err Then
      MsgBox "     文件夹中有下级目录不能删除  ！     ", 16, "☆-错误提示"
      Err.Clear
   Else
      RmDir (Dir1.List(Dir1.ListIndex))
   End If
   On Error GoTo 0                                   '忽略错误结束
   Dir1.Refresh
End Sub
但 Err 不一定只是“文件夹中有下级目录”的错误 
请of123请老师指点是否合理

Answer 7

抱歉，且代码的时候，把 Do While 条件错成 If 了：
Private Sub Command1_Click()
Dim strDirectory As String    strDirectory = Dir(Dir1.List(Dir1.ListIndex) & "\*.*", vbDirectory)
    Do While strDirectory > ""
        If strDirectory <> "." And strDirectory <> ".." Then
            MsgBox "Subdirectory found in the directory."
            Exit Sub
        End If
        strDirectory = Dir()
    Loop
    
    If Dir(Dir1.List(Dir1.ListIndex) & "\*.*") > "" Then
        MsgBox "File(s) found in the directory."
        Exit Sub
    End If
    
    RmDir (Dir1.List(Dir1.ListIndex))
    Dir1.RefreshEnd Sub

Answer 8

Dim strDirectory As String    If Dir1.ListIndex < 0 Then
       MsgBox "     不能删除打开了的文件夹  ！     ", 16, "☆-错误提示"
       Exit Sub
    End If
    
    strDirectory = Dir(Dir1.List(Dir1.ListIndex) & "\*.*", vbDirectory)
    Do While strDirectory > ""
        If strDirectory <> "." And strDirectory <> ".." Then
            MsgBox "     文件夹中有下级目录不能删除  ！     ", 16, "☆-错误提示"
            Exit Sub
        End If
        strDirectory = Dir()
    Loop
    
    If Dir(Dir1.List(Dir1.ListIndex) & "\*.*") > "" Then
        MsgBox "     不能删除内有文件的文件夹  ！     ", 16, "☆-错误提示"
        Exit Sub
    End If
    
    RmDir (Dir1.List(Dir1.ListIndex))
    Dir1.Refresh

Answer 9

Do While strDirectory > ""    
   If strDirectory <> "." And strDirectory <> ".." Then       
      MsgBox "     文件夹中有下级目录不能删除  ！     ", 16, "☆-错误提示"     
      Exit Sub      
   End If       
   strDirectory = Dir()
Loop
    这个Do循环和if ... 也是文件夹内不管是文件夹还是文件 都成立。所以得把：
If Dir(Dir1.List(Dir1.ListIndex) & "\*.*") > "" Then       
    MsgBox "     不能删除内有文件的文件夹  ！     ", 16, "☆-错误提示"      
    Exit Sub    
End If
这个if ...  放在 Do 循环之前才有意义。谢谢老师不厌其烦的指导！