使用excel vba宏创建文件夹和文件,并显示树视图和超链接(Make folders and files using excel vba macro and display with tree view and hyperlinks)

Office IT屋
问 题

I would like to make folder and file by reading the following paths

       /project/tags/folder2/command.txt
       /project/branches/folder1/folder1.1/Notes.docx

and construct folders and files under drive D:\ likes this

      project
          tags
              folder2
                   command.txt
          branches
              folder1
                    folder1.1
                           Notes.docx

.Then use this physical structure to type tree view with hyperlinks(Please assume I mark * for the names that words have hyperlinks) at last files and folders in excel sheet using vba macro.See

      project
         |_tags
         |   |_folder2*
         |         |_command.txt*
         |_branches
         |     |_folder1
         |           |_folder1.1*
         |                 |_Notes.docx*

So please help something for vba noob.

解决方案

I think that should do the trick. This macro will take folder path from cell A1 and list recursively its contents and subfolder contents with hyperlinks. Update: fixed, now it's working. :)

Public Position As Integer
Public Indent As Integer

Sub ListFileTree()

Position = 0
Indent = 0

Call RecurseFolderList(Range("A1").Value)

End Sub

Private Sub ClearFormatting(Rng As Range)

    Rng.Formula = Rng.Value2
    Rng.Font.ColorIndex = xlAutomatic
    Rng.Font.Underline = xlUnderlineStyleNone

End Sub

Function GetFilenameFromPath(ByVal strPath As String) As String
    If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
        GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
    End If
End Function

Function RecurseFolderList(FolderName As String) As Boolean
    On Error Resume Next
    Dim FSO, NextFolder, FolderArray, FileArray, NextFile
    Dim OriginalRange As Range
    Dim RemoveHyperlink As Boolean
    Set FSO = CreateObject("Scripting.FileSystemObject")

    If Err.Number > 0 Then
        RecurseFolderList = False
    Exit Function

    End If

    On Error GoTo 0
    If FSO.FolderExists(FolderName) Then

        Set NextFolder = FSO.GetFolder(FolderName)
        Set FolderArray = NextFolder.SubFolders
        Set FileArray = NextFolder.Files

        RemoveHyperlink = False
        Set OriginalRange = Range("A2").Offset(Position - 1, Indent)

        Indent = Indent + 1

        For Each NextFolder In FolderArray

            Range("A2").Offset(Position, Indent).Formula = "=HYPERLINK(""" & NextFile & """,""" & UCase(GetFilenameFromPath(NextFolder)) & """)"
            Position = Position + 1

            RecurseFolderList (NextFolder)

            RemoveHyperlink = True
        Next

        For Each NextFile In FileArray

            Range("A2").Offset(Position, Indent).Formula = "=HYPERLINK(""" & NextFile & """,""" & GetFilenameFromPath(NextFile) & """)"
            Position = Position + 1

            RemoveHyperlink = False

            DoEvents
        Next

        If RemoveHyperlink Then
            Call ClearFormatting(OriginalRange)
        End If

        Set NextFolder = Nothing
        Set FolderArray = Nothing
        Set FileArray = Nothing
        Set NextFile = Nothing

    Else
        RecurseFolderList = False
    End If

    Set FSO = Nothing
    Indent = Indent - 1

End Function

本文地址:IT屋 » Make folders and files using excel vba macro and display with tree view and hyperlinks

问 题

我想通过阅读以下路径来创建文件夹和文件



  /project/tags/folder2/command.txt 
/project/branches/folder1/folder1.1/Notes.docx


并构造文件夹和驱动器下的文件D:\喜欢这个



 项目
标签
folder2
命令.txt
branches
folder1
folder1.1
Notes.docx


。然后使用此物理结构使用超级链接键入树视图(请假设我使用vba宏在excel表格中的最后文件和文件夹标记*为单词具有超链接的名称*)。参阅



 项目
| _tags
| | _folder2 *
| | _command.txt *
| _branches
| | _folder1
| | _folder1.1 *
| | _Notes.docx *


所以请帮助vba noob。


解决方案

我认为应该这样做。
此宏将从单元格 A1 中获取文件夹路径,并以超链接递归列出其内容和子文件夹内容。
更新:已修复,现在正在运行。 :)

 公开位置为整数
公共缩进为整数

Sub ListFileTree()

位置= 0
缩进= 0

调用RecurseFolderList(Range(“A1”)。Value)

End Sub

Private Sub ClearFormatting(Rng As Range)

Rng.Formula = Rng.Value2
Rng.Font.ColorIndex = xlAutomatic
Rng.Font.Underline = xlUnderlineStyleNone

End Sub

函数GetFilenameFromPath(ByVal strPath As String)As String
如果右$(strPath,1)<> “\”And Len(strPath)> 0然后
GetFilenameFromPath = GetFilenameFromPath(Left $(strPath,Len(strPath) - 1))+ Right $(strPath,1)
End If
End Function

函数RecurseFolderList(FolderName As String)As Boolean
On Error Resume Next
Dim FSO,NextFolder,FolderArray,FileArray,NextFile
Dim OriginalRange As Range
Dim RemoveHyperlink As Boolean
Set FSO = CreateObject(“Scripting.FileSystemObject”)

如果Err.Number> 0然后
RecurseFolderList = False
退出函数

结束如果

错误GoTo 0
如果FSO.FolderExists(FolderName)Then

设置NextFolder = FSO.GetFolder(FolderName)
设置FolderArray = NextFolder.SubFolders
设置FileArray = NextFolder.Files

RemoveHyperlink = False
设置OriginalRange =范围(“A2”)。偏移(位置-1,缩进)

缩进=缩进+ 1

对于每个NextFolder在FolderArray

Range(“A2”)。Offset(Position,Indent).Formula =“= HYPERLINK(”“”& NextFile&“”“”“”&“”(GetFilenameFromPath(NextFolder))& “”)“
位置=位置+ 1

RecurseFolderList(NextFolder)

RemoveHyperlink = True
下一个

每个NextFile In FileArray

Range(“A2”)。Offset(Position,Indent).Formula =“= HYPERLIN K(“”“& NextFile& “”“”“”& GetFilenameFromPath(NextFile)& “”“”)“
位置=位置+ 1

RemoveHyperlink = False

DoEvents
下一个

如果RemoveHyperlink Then
调用ClearFormatting(OriginalRange)
如果

设置NextFolder = Nothing
设置FolderArray = Nothing
设置FileArray = Nothing
Set NextFile =没有

Else
RecurseFolderList = False
结束如果

设置FSO =没有
缩进=缩进 - 1

结束功能

本文地址:IT屋 » 使用excel vba宏创建文件夹和文件,并显示树视图和超链接