如何从 Excel (VBA) 生成完整的 OneDrive 共享 link？

Question

我刚才有一个问题，我找不到合适的答案......好吧，我最后找到了答案，现在发帖希望有人会觉得它有用。

我需要创建一个文件，将其保存在我的 onedrive 文件夹中，然后创建一个共享 link。只是为了消除可能的误解，Thisworkbook.Fullname 是行不通的。我需要对所有新创建的文件进行完整共享 link。

Answer 1

基本上，我只是模拟单击我的一个驱动器文件夹中的文件来共享 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

如何从 Excel (VBA) 生成完整的 OneDrive 共享 link？

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

excel

vba

share

hyperlink

onedrive