Monday, 20 November 2017

Use Shell API to VBA Script OneDrive Sync

So my computer is very slow in the Windows Explorer and I was looking to use the OneDrive (SkyDrive) to backup files. To force a synchronisation one right clicks on the OneDrive icon and selects 'Sync' but this menu is very very slow to appear to for me currently and I was wondering if it could be coded in VBA.

I found a StackOverflow answer which points to a nice JavaScript file on GitHub that uses the 'Microsoft Shell Controls and Automation' type library (albeit late binding). I have converted the code to VBA. The code gets the OneDrive folder item, and uses the Verbs method to get the list that appears when one right clicks to get context menu. To mimic pressing a menu option one calls DoIt on the Verb object.

I am curious to investigate how to add functionality to the Shell namespace now that I have discovered how to invoke such functionality. In the meantime here is some code.


Option Explicit
Option Private Module

'*Tools->References
'* Microsoft Scripting Runtime                      C:\Windows\sysWOW64\scrrun.dll
'* Microsoft Shell Controls and Automation          C:\Windows\sysWOW64\shell32.dll

Private Sub TestSyncItem()
    SyncItem ""
End Sub

Private Sub SyncItem(Optional ByVal sItemName As String)

    '* Based on https://github.com/npocmaka/batch.scripts/blob/master/hybrids/jscript/oneDriveSync.bat

    Dim objFSO As New Scripting.FileSystemObject
    Dim objShell As New Shell32.Shell  'ActiveXObject("Shell.Application");
    
    If LenB(sItemName) = 0 Then sItemName = GetOneDrivePathFromReg

    
    If objFSO.FolderExists(sItemName) Or objFSO.FileExists(sItemName) Then
    
        Dim sFullItemName As String
        sFullItemName = objFSO.GetAbsolutePathName(sItemName)
        
        Dim sNamespace As String
        sNamespace = objFSO.GetParentFolderName(sFullItemName)
        
        Dim sName As String
        sName = objFSO.GetFolder(sFullItemName).name
    
        '* Introduction to the Shell Namespace
        '* https://msdn.microsoft.com/en-us/library/windows/desktop/cc144090(v=vs.85).aspx
        Dim objFolder As Shell32.Folder
        Set objFolder = objShell.namespace(sNamespace)
        
    
        Dim objItem As Shell32.FolderItem
        Set objItem = objFolder.ParseName(sName)
        
        Dim oFolderItemVerb As Shell32.FolderItemVerb
        Set oFolderItemVerb = Nothing
        
        Dim vVerbLoop As Variant
        For Each vVerbLoop In objItem.Verbs
            If vVerbLoop.name = "Sync" Then
                Set oFolderItemVerb = vVerbLoop
                Exit For
            End If
        
        Next vVerbLoop
        If Not oFolderItemVerb Is Nothing Then
            Call oFolderItemVerb.DoIt
        
        End If
        Stop
    End If
    
End Sub

Private Function GetOneDrivePathFromReg() As String
    Const HKCU As Long = &H80000001
    
    Dim registryObject As Object
    Set registryObject = VBA.GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
             ".\root\default:StdRegProv")
    
    Dim sRet As String
    registryObject.GetStringValue HKCU, "Software\Microsoft\OneDrive", "UserFolder", sRet
    GetOneDrivePathFromReg = sRet
End Function




1 comment:

  1. I just download and use "Long Path Tool" to fix your error fast and easy.

    ReplyDelete