How to generate full OneDrive share link from Excel (VBA)?

Question

I had a question while ago on which I couldn't find a proper answer... Well, I figured out the answer on the end and now posting in hope that someone will find it useful.

I needed to create a file, save it in my onedrive folder, and create a shared link. Just to sort out possible misunderstanding, Thisworkbook.Fullname wouldn't work. I needed a full sharing link for all newly created files.

Answer 1

Basically, I just simulate clicking file in my one drive folder to get shared link:

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 wMsg 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"))
        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