• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Fetch folder and sub-folders from dropbox

YasserKhalil

YasserKhalil

Well-Known Member
Hello everyone
With the awesome help of Mr. Marc before I could adopt the following code to make it working
Code: 
Const url As String = "https://www.dropbox.com/sh/v4zcawgs32v7qc9/AAALfDRjpNOT8NnOTL_4XAXja?dl=0"

Sub Grab_All_DropBox_URLs_In_Main_Folder_And_SubFolders()
    Dim v          As Variant
    Dim y          As Variant
    Dim n          As Long
    Dim p          As Long
    Dim r          As Long

    Application.ScreenUpdating = False
        With CreateObject("WinHttp.WinHttpRequest.5.1")
            .Open "GET", url, False
            .setRequestHeader "DNT", "1"
            On Error Resume Next
                .send
                If .Status = 200 Then v = Split(.responseText, """filename"": """)
            On Error GoTo 0
        End With
   
        If IsArray(v) Then
            For n = 1 To UBound(v) - 1
                If InStr(Split(v(n), """")(0), ".") = 0 Then
                    With CreateObject("WinHttp.WinHttpRequest.5.1")
                        .Open "GET", Split(Split(v(n), """href"": """)(1), """")(0), False
                        .setRequestHeader "DNT", "1"
                        On Error Resume Next
                            .send
                            If .Status = 200 Then y = Split(.responseText, """filename"": """)
                        On Error GoTo 0
                    End With
   
                    If IsArray(y) Then
                        For p = 1 To UBound(y) - 1
                            r = r + 1
                            Cells(r, 1).Value = Split(y(p), """")(0)
                            Cells(r, 2).Value = Split(Split(y(p), """href"": """)(1), """")(0)
                        Next p
                    End If
                Else
                    r = r + 1
                    Cells(r, 1).Value = Split(v(n), """")(0)
                    Cells(r, 2).Value = Split(Split(v(n), """href"": """)(1), """")(0)
                End If
            Next n
        End If
    Application.ScreenUpdating = True
End Sub

This code is grabbing dropbox files from the folder and subfolders
and it is working with the current URL but doesn't work for the following URL
Code: 
Const url As String = "https://www.dropbox.com/sh/47uje0uvl2sulo2/AABS_TUqqwK3oYwnbcN6Gj4Fa?dl=0"

Any help in this issue please
 
Probably because you have so many images in root folder. It's taking long time to get full response.

Took a while to just open the link (I walked away and got coffee before it finished loading the page).
 
Nope, Application.Wait probably won't do it.

Because likely issue is that Winhttp request itself is timing out somewhere during one of following process; resolve, connect, send or receive.

Try setting ridiculously large value for each (5 min) and see what happens.
See link for use and syntax on settimeouts.
http://www.808.dk/?code-simplewinhttprequest

Though it's for VBScript, but same concept applies.

Alternately try using MSXML2 since it has no timeout.

Still, response text is about 4Mb in size... restructuring dropbox folders is probably prudent.
 
Thank you very much. I thought there must be other changes related to that change in fact
I will try that to see the results but I welcome any better ideas
 
I tested that and it works well
How can I deep in sub folders .. Is there a way to search for all the sub folders?
I mean sometimes there are sub folder into the folder and inside the sub folder there are other sub folders ..
 
Hints:
1. Make use of Collection/Dictionary to store result. It makes collecting result from recursive procedure much easier (and perhaps more importantly, faster) than out putting result into sheet directly.

2. Module should be split into two part. One for recursive process, that calls itself when condition is met (i.e. If string contains "."). And another to initiate the process and create container to collect info and output to sheet.
 
Thank you very much for those useful links. I have studied those links well and got most of it.. But I still couldn't implement that recursive technique to my code
 
Here's sample.
Code: 
Public dic As Object

Sub recCrawl(url As String)
    Dim v          As Variant
    Dim n          As Long
    Dim lurl      As String
   
    Application.ScreenUpdating = False
        With CreateObject("MSXML2.xmlhttp")
            .Open "GET", url, False
            .setRequestHeader "DNT", "1"
            On Error Resume Next
                .send
                If .Status = 200 Then v = Split(.responseText, """filename"": """)
            On Error GoTo 0
        End With
 
        If IsArray(v) Then
            For n = 1 To UBound(v) - 1
                If InStr(Split(v(n), """")(0), ".") = 0 Then
                    lurl = Split(Split(v(n), """href"": """)(1), """")(0)
                    Call recCrawl(lurl)
                Else
                    dic(Split(Split(v(n), """href"": """)(1), """")(0)) = Split(v(n), """")(0)
                End If
            Next n
        End If
    Application.ScreenUpdating = True
End Sub

Sub RunRec()
Set dic = CreateObject("Scripting.Dictionary")
Call recCrawl("https://www.dropbox.com/sh/47uje0uvl2sulo2/AABS_TUqqwK3oYwnbcN6Gj4Fa?dl=0")
Range("A1").Resize(dic.Count) = Application.Transpose(dic.Items)
Range("B1").Resize(dic.Count) = Application.Transpose(dic.Keys)
Set dic = Nothing
End Sub

If dic.Count exceeds limit of Transpose. You'll need to implement another process in RunRec to put contents into array (or loop through dictionary to put it into sheet directly).

Key Points:
1. There are identical file names (but different image) in separate folders, hence link url was used as Key and file name as Item.

2. Only single loop is needed as it calls upon itself to loop through subfolders.

3. Dictionary is used as container and filled implicitly.
 
That's really awesome and fascinating
But it seems that using Transpose with dictionary won't suit the big URL .. so I tried to use the arrays in this way but it seems that I didn't succeed. Can you point me where is the error that I made
Code: 
Public arr() As Variant

Sub recCrawl(url As String)
    Dim v          As Variant
    Dim n          As Long
    Dim lurl      As String
  Dim i As Long
 
    Application.ScreenUpdating = False
        With CreateObject("MSXML2.XMLHTTP")
            .Open "GET", url, False
            .setRequestHeader "DNT", "1"
            On Error Resume Next
                .Send
                If .Status = 200 Then v = Split(.responseText, """filename"": """)
            On Error GoTo 0
        End With
        If IsArray(v) Then
            For n = 1 To UBound(v) - 1
                If InStr(Split(v(n), """")(0), ".") = 0 Then
                    lurl = Split(Split(v(n), """href"": """)(1), """")(0)
                    Call recCrawl(lurl)
                Else
                    i = i + 1
                    ReDim Preserve arr(1 To 2, 1 To i)
                    arr(1, i) = Split(v(n), """")(0)
                    arr(2, i) = Split(Split(v(n), """href"": """)(1), """")(0)
                    'dic(Split(Split(v(n), """href"": """)(1), """")(0)) = Split(v(n), """")(0)
                End If
            Next n
        End If
    Application.ScreenUpdating = True
End Sub

Sub RunRec()
'Set dic = CreateObject("Scripting.Dictionary")
'Dim a
'Call recCrawl("https://www.dropbox.com/sh/47uje0uvl2sulo2/AABS_TUqqwK3oYwnbcN6Gj4Fa?dl=0")
Call recCrawl("https://www.dropbox.com/sh/v4zcawgs32v7qc9/AAALfDRjpNOT8NnOTL_4XAXja?dl=0")
arr = Application.Transpose(arr)
Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
'Range("A1").Resize(dic.Count) = Application.Transpose(dic.Items)
'Range("B1").Resize(dic.Count) = Application.Transpose(dic.Keys)
'Set dic = Nothing
Erase arr
End Sub
 
This is the working code for me now
Code: 
Public a()      As Variant
Public i        As Long

Sub recCrawl(url As String)
    Dim v      As Variant
    Dim sUrl    As String
    Dim n      As Long
   
    Application.ScreenUpdating = False
        With CreateObject("MSXML2.XMLHTTP")
            .Open "GET", url, False
            .setRequestHeader "DNT", "1"
            On Error Resume Next
                .Send
                If .Status = 200 Then v = Split(.responseText, """filename"": """)
            On Error GoTo 0
        End With
   
        If IsArray(v) Then
            For n = 1 To UBound(v) - 1
                If InStr(Split(v(n), """")(0), ".") = 0 Then
                    sUrl = Split(Split(v(n), """href"": """)(1), """")(0)
                    Call recCrawl(sUrl)
                Else
                    i = i + 1
                    ReDim Preserve a(1 To 2, 1 To i)
                    a(1, i) = Split(v(n), """")(0)
                    a(2, i) = Split(Split(v(n), """href"": """)(1), """")(0)
                End If
            Next n
        End If
    Application.ScreenUpdating = True
End Sub

Sub Grab_DropBox_Links()
    'Call recCrawl("https://www.dropbox.com/sh/47uje0uvl2sulo2/AABS_TUqqwK3oYwnbcN6Gj4Fa?dl=0")
    Call recCrawl("https://www.dropbox.com/sh/v4zcawgs32v7qc9/AAALfDRjpNOT8NnOTL_4XAXja?dl=0")

    a = Application.Transpose(a)
    Range("A1").Resize(UBound(a, 1), UBound(a, 2)).Value = a

    Erase a: i = 0
End Sub
 
Last edited:
That's going to be slow since you are redimming at each iteration, and you are still using transpose, which is the limiting factor (also has memory impact).

Instead use dictionary as container as is, and then transfer contents to array.

Only change is in RunRec().
Code: 
Sub RunRec()
Dim arr(), i As Long: i = 1
Set dic = CreateObject("Scripting.Dictionary")
Call recCrawl("https://www.dropbox.com/sh/47uje0uvl2sulo2/AABS_TUqqwK3oYwnbcN6Gj4Fa?dl=0")
ReDim arr(1 To dic.Count, 1 To 2)

For Each Key In dic.Keys
    arr(i, 1) = dic(Key)
    arr(i, 2) = Key
    i = i + 1
Next

Range("A1").Resize(dic.Count, 2) = arr

Set dic = Nothing
End Sub
 
Thank you very very very much for great and awesome help Mr. Chihiro
I appreciate a lot all your great help
Best and Kind Regards
 
You must log in or register to reply here.
Back
Top