VBA to obtain Dropbox folder location into Excel

[Mrsbex]

Hi All,

I have a macro which worked beautifully on my PC to save a workbook to Dropbox. However, when a colleague tried to use it, it didn't work because Dropbox on their PC is not in the usual place. I have looked into obtaining the Dropbox directory from the json file but I don't know how to do it all automatically as it is beyond my skill-set.

This is my original macro which worked when the Dropbox folder is where it should be...

Sub SaveIt()
    Dim FName As String
    Dim Dboxdirectory As String
    
    Dboxdirectory = Environ("USERPROFILE") & "\Dropbox\ORDERS\To be processed\"
    FName = ThisWorkbook.Worksheets("Fashion").Range("D2").Value
    ActiveWorkbook.SaveAs Filename:=Dboxdirectory & FName & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
    
End Sub

I tried recording a macro while inserting my info.json file into the workbook so I could pull the directory from the table it produces it to use in the above code, but of course, when I tried to edit it to look in the userprofile directory to obtain the json file on any PC it threw it's rattle out of it's pram and now I'm lost. What it does is see the Dim reference literally, and passes that across to the query builder instead of the path so it tries to add this path in the query "= Json.Document(File.Contents( JsonDir & "\info.json"))"

This is what I have tried...

Sub GetDropboxJson()


    Dim FName As String
    Dim JsonDir As String
    JsonDir = Environ("USERPROFILE") & "\AppData\Local\Dropbox"
    ActiveWorkbook.Queries.Add Name:="info", Formula:= _
        "let" & Chr(13) & "" & Chr(10) & "    Source = Json.Document(File.Contents( JsonDir & ""\info.json""))," & Chr(13) & "" & Chr(10) & "    #""Converted to Table"" = Record.ToTable(Source)" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Converted to Table"""
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=info;Extended Properties=""""" _
        , Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array("SELECT * FROM [info]")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .ListObject.DisplayName = "info"
    End With
End Sub

Please can someone help?

Thanks.

 

[6StringJazzer]

Please try this. My own info.json file is only one line, so that's what I assumed for this solution. The Dropbox site shows it spread out over multiple lines, but that may be just to illustrate.

Sub SaveIt()
    Dim FName As String
    Dim Dboxdirectory As String
    
    Dboxdirectory = [COLOR=#FF0000]DropboxPath & "[/COLOR]\ORDERS\To be processed\"
    FName = ThisWorkbook.Worksheets("Fashion").Range("D2").Value
    ActiveWorkbook.SaveAs Filename:=Dboxdirectory & FName & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
    
End Sub


' If there are multiple dropbox accounts on this machine, this will
' only get the first one
Public Function DropboxPath() As String

   Dim RegEx As Object
   Dim MatchColl As Object
   Dim DataLine As String
   Const FileNum = 1 ' Assumes no other files are open!!
   
   Set RegEx = CreateObject("VBScript.RegExp")
   RegEx.Global = True
   RegEx.IgnoreCase = False
   
   ' Open the Dropbox configuration file
   ' This is a JSON file that is human-readable
   ' The first line of the file has configuration for the first Dropbox account
   ' The first attribute is the path
   Open Environ("LOCALAPPDATA") & "\Dropbox\info.json" For Input As [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FileNum"]#FileNum[/URL] 
   
   Do While Not EOF(FileNum)
       Line Input [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FileNum"]#FileNum[/URL] , DataLine ' read in data 1 line at a time
       ' decide what to do with dataline,
       ' depending on what processing you need to do for each case
   Loop
   
   Close [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FileNum"]#FileNum[/URL] 

   RegEx.Pattern = "^.*""path"": ""([^""]*).*"

   DropboxPath = Replace(RegEx.Replace(DataLine, "$1"), "", "")

End Function

Public Sub Test()
   MsgBox "Dropbox path:" & vbCrLf & DropboxPath
End Sub

 

[Mrsbex]

Thanks 6StringJazzer it worked except for some reason it never changed the \\ to \ so I created a new sheet called DropboxPathResult and added the code below to an autoopen macro so it updates when the workbook is opened, no matter which computer it's on, and changes the \\ to \ at the same time.

Call DropboxPath    
    Sheets("DropboxPathResult").Activate
    ActiveSheet.Cells(1, 1).Select
    ActiveCell.FormulaR1C1 = "=DropboxPath()"
    Range("A1").Select
    Selection.Copy
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A2").Select
    Cells.Replace What:="\\", Replacement:="\", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

Thank you so much for your help!

 

[6StringJazzer]

When I run it I don't get any \\ just the single \ . I don't understand why you have to make that change.

 

[Jon Peltier]

I added one line before the end of Function Dropboxpath():

Public Function DropboxPath() As String
   Dim RegEx As Object
   Dim MatchColl As Object
   Dim DataLine As String
   Const FileNum = 1 ' Assumes no other files are open!!
   
   Set RegEx = CreateObject("VBScript.RegExp")
   RegEx.Global = True
   RegEx.IgnoreCase = False
   
   ' Open the Dropbox configuration file
   ' This is a JSON file that is human-readable
   ' The first line of the file has configuration for the first Dropbox account
   ' The first attribute is the path
   Open Environ("LOCALAPPDATA") & "\Dropbox\info.json" For Input As [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FileNum]#FileNum[/URL] 
   
   Do While Not EOF(FileNum)
       Line Input [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FileNum]#FileNum[/URL] , DataLine  ' read in data 1 line at a time
       ' decide what to do with dataline,
       ' depending on what processing you need to do for each case
   Loop
   
   Close [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FileNum]#FileNum[/URL] 

   RegEx.Pattern = "^.*""path"": ""([^""]*).*"

   DropboxPath = Replace(RegEx.Replace(DataLine, "$1"), "", "")

   DropboxPath = Replace(DropboxPath, "\", "") '' Change double to single backslash
End Function

 

[Mrsbex]

When I run it I don't get any \\ just the single \ . I don't understand why you have to make that change.

I don't know why yours and mine are different. When I look at the json file, it has \\ in the path. It's not a problem, the tweak worked for me. I appreciate the help, I'd never have got anywhere otherwise! Thank you

 

[Mrsbex]

DropboxPath = Replace(DropboxPath, "", "") '' Change double to single backslash
End Function[/CODE]

This is great, thanks, I've learned loads from this thread, and knowing how to do these things in VBA is really exciting (if you're me...)

 

[6StringJazzer]

I'm sorry for the confusion. I went back and looked at my working code and it is exactly like what Jon Peltier posted. I must have posted my code above before I was completely finished.