如何从ExcelVBA生成完整的OneDrive共享链接？

如何解决如何从ExcelVBA生成完整的OneDrive共享链接？

前段时间我有一个问题，找不到合适的答案...好吧，我终于弄清楚了答案，现在发布，希望有人会觉得有用。

我需要创建一个文件，将其保存在我的onedrive文件夹中，并创建一个共享链接。只是为了解决可能的误解，Thisworkbook.Fullname是行不通的。我需要所有新创建文件的完整共享链接。

解决方法

基本上，我只是模拟单击一个驱动器文件夹中的文件以获取共享链接：

Const WM_SYSCOMMAND = &H112
Const SC_CLOSE = &HF060

#If VBA7 Then
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
        (ByVal hWnd As LongPtr,ByVal wMsg As Long,ByVal wParam As LongPtr,lParam As Long) As LongPtr
#Else
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
        (ByVal hWnd As Long,ByVal wParam As Long,lParam As Long) As Long
#End If

Sub FrankensteinCodeToGetLink()
   
    Dim objFSO As Object,objFolder As Object,objfile As Object
    Dim sFolder As String
    Dim dataObj As MSForms.DataObject

    sFolder = "<Your One Drive folder address (eg.:C:\Users\Omen\OneDrive\Dokument>"

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(str_folder)

i = 1
    For Each objFile In objFolder.Files
        Shell "explorer.exe /select,""" & objFolder & "\" & objFile.Name & """",vbNormalFocus
        
        'wait time is not needed,but it kept crashing here and there without it if windows bumps in execution
        If InStr(objFile.Name,"Error") > 0 Then GoTo errLOG
        Application.Wait (Now + #12:00:03 AM#)
        
        'right click on selected file
        Application.SendKeys ("+{F10}"),Wait:=True
        Application.Wait (Now + #12:00:02 AM#)
        
        'shortcut to go to Share function inside of right-click menu
        Application.SendKeys ("s"),Wait:=True
        Application.Wait (Now + #12:00:02 AM#)
        
        'open share function
        SendKeys String:="{enter}",Wait:=True
        Application.Wait (Now + TimeValue("00:00:02"))
        
        'loop until get to the copy link part
        Application.SendKeys ("{TAB}"),Wait:=True
        Application.Wait (Now + TimeValue("00:00:02"))
        Application.SendKeys ("{TAB}"),Wait:=True
        Application.Wait (Now + TimeValue("00:00:02"))
        
        'enter copy link function of share link
        SendKeys String:="{enter}",Wait:=True
        Application.Wait (Now + TimeValue("00:00:02"))
        
        'copy to clipboard
        Application.SendKeys ("^c")
        Application.Wait (Now + TimeValue("00:00:02"))
        
        'close sharing window
        Application.SendKeys ("%{F4}"),Wait:=True
        
        'get data from clipboard
        On Error GoTo PasteFailed
        Set dataObj = New MSForms.DataObject
        dataObj.GetFromClipboard
        
        Sheets("Sheet1").Range("A" & i).Value = dataObj.GetText(1) 
        i = i + 1
        
        'close opened folder window
        Call CloseWindowExample(str_folder)

PasteFailed:
        On Error GoTo 0
        Exit Sub
        
errLOG:
        MsgBox (objFile.Name& " couldn't be retrieved!")
        Exit Sub
    Next objFile
    

End Sub

Public Sub CloseWindowExample(str_folder As String)
    Dim sh As Object
    Set sh = CreateObject("shell.application")

    Dim w As Variant
    For Each w In sh.Windows

        ' select correct shell window by LocationURL
        If Application.Substitute(w.LocationURL,"%20"," ") = "file:///" & str_folder Then
            SendMessage w.hWnd,WM_SYSCOMMAND,SC_CLOSE,0
        End If
    Next w
End Sub