返回到指定级数的目录

zzf_

Sub mmll()
    Dim theSh As Object
    Dim theFolder As Object
    Set theSh = CreateObject("shell.application")
        ';;;;;;;;;
        myPath = Range("g7").Value
        
           If InStr(myPath, "\") Then
                k = Len(myPath) - Len(Replace(myPath, "\", "")) '计算单元格g7中路径名中的"\"个数
               
                x = Cells(6, 6) '为要返回目录的级数：0表示本级目录及以下；1表示上一级；2表示上两级，以此类推
                If x > 0 Then
                   If k >= x Then
                      N = InStr(Replace(myPath, "\", " ", , k - x), "\")
           
                      temp = Left(myPath, N - 1) '取得上x级目录名称
                           
                      Range("g7").Value = temp
                          Else
                      Range("g7").Value = "&H11" '如果上x级目录是硬盘的根目录，则给单元格g7赋值=&H11
                   End If
                 Else
                                    
                End If
           End If
            
        
    ';;;;;;;;;;;;;;;;;;
    Set theFolder = theSh.BrowseForFolder(&O0, "请选择文件夹", &H1 + &H10, Range("g7").Value)
   
    If Not theFolder Is Nothing Then
        Range("g7").Value = theFolder.Items.Item.Path
    End If
   
    Set theFolder = Nothing
End Sub
源码来自论坛拼凑


[ 本帖最后由 zzf_ 于 2010-4-23 13:51 编辑 ]

cflood

谢谢分享，学习

lb_bn

谢谢楼主分享，支持原创．

JLF2003

谢谢楼主分享，支持原创．

zzf_

各位大师
Cells(6, 6)的数据有效性如何做？
想让其显示下拉框，数值从0到k（单元格g7中路径名中的"\"个数）

这样当前目录能返回的最多级数就一目了然了

zzf_

';;;;;;;;;;;;;;;;;;
    Set theFolder = theSh.BrowseForFolder(&O0, "请选择文件夹", &H1 + &H10, Range("g7").Value)
   
    If Not theFolder Is Nothing Then
        Range("g7").Value = theFolder.Items.Item.Path
    End If
    '==================
    If Range("g7").Value <> "&H11" Then
    Set theFolder = Nothing
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(Range("g7").Value)
      fNumber = f.SubFolders.Count
          If fNumber = 0 Then
                 MsgBox ("该文件夹下无子目录了！")
                      If f.Size = 0 Then
                          MsgBox ("无有效文件")
                      End If
          End If
    End If
   End Sub

[ 本帖最后由 zzf_ 于 2010-4-23 15:17 编辑 ]

zzf_

'==================判断g7单元格中路径下是否有文件及有效文件（文件长度大于0的）
   With Application.FileSearch
  .LookIn = Range("g7").Value

除错

zzf_

Sub mmll()
    Dim theSh As Object
    Dim theFolder As Object
        Set theSh = CreateObject("shell.application")
        ';;;;;;;;;
        myPath = Range("g7").Value
                   If InStr(myPath, "\") Then
                   k = Len(myPath) - Len(Replace(myPath, "\", "")) '计算单元格g7中路径名中的"\"个数
           x = Cells(6, 6) '为要返回目录的级数：0表示本级目录及以下；1表示上一级；2表示上两级，以此类推
                If x > 0 Then
                               If k >= x And Len(myPath) > 3 Then '改一下，能返回到我的电脑

zzf_

Sub mmll()
    Dim theSh As Object
    Dim theFolder As Object
   
    Set theSh = CreateObject("shell.application")
        ';;;;;;;;;
        myPath = Range("g7").Value
        
           If InStr(myPath, "\") Then
                k = Len(myPath) - Len(Replace(myPath, "\", "")) '计算单元格g7中路径名中的"\"个数
               
                x = Cells(6, 7) '为要返回目录的级数：0表示本级目录及以下；1表示上一级；2表示上两级，以此类推，此处添加了数据有效性
                If x > 0 Then
                   If k >= x And Len(myPath) > 3 Then
                      N = InStr(Replace(myPath, "\", " ", , k - x), "\")
           
                      temp = Left(myPath, N - 1) '取得上x级目录名称
                       Range("g7").ClearContents
                       Range("g7").Value = temp
                          Else
                      Range("g7").Value = "&H11" '如果上x级目录是硬盘的根目录，则给单元格g7赋值=&H11
                   End If
                 Else
                                    
                End If
           End If
           
      
    ';;;;;;;;;;;;;;;;;;
    Set theFolder = theSh.BrowseForFolder(&O0, "请选择文件夹", &H1 + &H10, Range("g7").Value)
   
    If Not theFolder Is Nothing Then
        Range("g7").Value = theFolder.Items.Item.Path
    End If
    '==================
    If Range("g7").Value <> "&H11" Then
    Set theFolder = Nothing
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(Range("g7").Value)
      fNumber = f.SubFolders.Count
          If fNumber = 0 Then
            MsgBox ("该文件夹下无子目录了！")
                      If f.Size = 0 Then
                          MsgBox ("无有效文件")
                      End If
          End If
    End If
   '==================Cells(6, 7)添加数据有效性
   
   Dim R As String
   Dim ss As Long
     Cells(6, 7).Validation.Delete
     kkk = Len(Range("g7").Value) - Len(Replace(Range("g7").Value, "\", ""))
        For ss = 0 To kkk
              R = R & "," & ss
        Next ss
    Range("g6").ClearContents
    Cells(6, 7).Validation.Add 3, 1, 1, R

   '==================
   
   
   End Sub

zzf_

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Target.Validation.Type = 4 Then
Exit Sub
Else
SendKeys "%{down}"
Target.Value = Split(Target.Validation.Formula1, ",")(0)
End If
End Sub