OneDriveの特定のフォルダにあるファイルの共有リンクを取得

Question

OneDriveの特定のフォルダにある各ファイルの共有リンク（編集）を取得するためのVBA（Excel）コードの例を教えていただけますか？ または役に立つリンク？完全に異なることだ

おかげ チューダー

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のテンプレートを設定し、以下のスクリプトを実行します。

とシート（ "シート1"）でリストを作成します：列Aで

：列Bの人々 の名前：Eメールアドレス欄の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

あなたが別の人に別のファイルを電子メールで送信したい場合は、以下のスクリプトを参照してください。

とシート（ "シート1"）でリストを作成します：列Aで

：列Bの人の名前

：E-mailアドレス

列Cで：Z：

マクロは "Sheet1"の各行をループし、B列に電子メールアドレスがある場合は となります。また、C：\ Data \ Book2.xlsのようなファイル名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