Question

有人能给我一个VBA（Excel）代码示例，以获取OneDrive中特定文件夹中每个文件的共享链接（编辑）吗？还是一个有用的链接？

由于铎

Answer 1

我不确定你要求的是什么，但也许就是这个......

Sub GetFolder_Data_Collection()

Range("A:L").ClearContents
Range("A1").Value = "Name"
Range("B1").Value = "Path"
Range("C1").Value = "Size (KB)"
Range("D1").Value = "DateLastModified"
Range("E1").Value = "Attributes"
Range("F1").Value = "DateCreated"
Range("G1").Value = "DateLastAccessed"
Range("H1").Value = "Drive"
Range("I1").Value = "ParentFolder"
Range("J1").Value = "ShortName"
Range("K1").Value = "ShortPath"
Range("L1").Value = "Type"
Range("A1").Select

Dim strPath As String
'strPath = "I:\Information Security\KRI Monthly Data Collection\"
strPath = GetFolder

Dim OBJ As Object, Folder As Object, File As Object

Set OBJ = CreateObject("Scripting.FileSystemObject")
Set Folder = OBJ.GetFolder(strPath)

Call ListFiles(Folder)

Dim SubFolder As Object

For Each SubFolder In Folder.SubFolders
    Call ListFiles(SubFolder)
    Call GetSubFolders(SubFolder)
Next SubFolder


End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub ListFiles(ByRef Folder As Object)

On Error Resume Next
For Each File In Folder.Files
        ActiveCell.Offset(1, 0).Select
        ActiveCell = File.Name
        ActiveCell.Offset(0, 1).Select
        ActiveCell.Offset(0, 1) = File.Path
            ActiveCell.Offset(0, 0).Hyperlinks.Add Anchor:=ActiveCell.Offset(0, 0), Address:=File.Path, TextToDisplay:=File.Path
        ActiveCell.Offset(0, -1).Select
        ActiveCell.Offset(0, 2) = (File.Size / 1024) 'IN KB
        ActiveCell.Offset(0, 3) = File.DateLastModified
        ActiveCell.Offset(0, 4) = File.Attributes
        ActiveCell.Offset(0, 5) = File.DateCreated
        ActiveCell.Offset(0, 6) = File.DateLastAccessed
        ActiveCell.Offset(0, 7) = File.Drive
        ActiveCell.Offset(0, 8) = File.ParentFolder
        ActiveCell.Offset(0, 9) = File.ShortName
        ActiveCell.Offset(0, 10) = File.ShortPath
        ActiveCell.Offset(0, 11) = File.Type
Next File

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub GetSubFolders(ByRef SubFolder As Object)

Dim FolderItem As Object
On Error Resume Next
For Each FolderItem In SubFolder.SubFolders
    Call ListFiles(FolderItem)
    Call GetSubFolders(FolderItem)
Next FolderItem

End Sub


Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

Answer 2

这是完全不同的事情。如果您想将不同的文件通过电子邮件发送给不同的人，请根据您的具体需求设置Excel“模板”，然后运行以下脚本。

在Sheets（“Sheet1”）中创建一个列表：

在A栏：人民的名字在B列：电子邮件地址在C列中：Z：像这样的文件名C：\ Data \ Book2.xls（不必是Excel文件）

宏将遍历“Sheet1”中的每一行，如果B列中有电子邮件地址和C列中的文件名：Z它将创建一个包含此信息的邮件并发送。

Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

        'Enter the path/file names in the C:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .to = cell.Value
                .Subject = "Testfile"
                .Body = "Hi " & cell.Offset(0, -1).Value

                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

                .Send  'Or use .Display
            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

https://www.rondebruin.nl/win/s1/outlook/amail6.htm

Answer 3

如果您想将不同的文件发送给不同的人，请参阅下面的脚本。

在表格（＆＃34; Sheet1＆＃34;）中创建一个列表：

在A栏：人物的姓名

在B栏：电子邮件地址

在C栏中：Z：像这样的文件名C：\ Data \ Book2.xls（不必是Excel文件）

宏将遍历＆＃34; Sheet1＆＃34;中的每一行。如果B栏中有电子邮件地址和C列中的文件名：Z它将创建一个包含此信息的邮件并发送。

Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

        'Enter the path/file names in the C:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .to = cell.Value
                .Subject = "Testfile"
                .Body = "Hi " & cell.Offset(0, -1).Value

                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

                .Send  'Or use .Display
            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

获取OneDrive特定文件夹中文件的共享链接

3 个答案: