Yandex Disk'ten dosya indirme

[cumay]

Sayın Üstadlar,

Aşağıdaki makro ile excelden web sayfası açıyorum (yandex disk). Sonra açılan sayfada "İNDİR" butonunu tıklayıp dosyayı indiriyorum.

Sub Web_Sayfası_Aç()
Sheets("YYY").Select
For i = 1 To Range("A1048576").End(xlUp).Row
If Cells(i, 1) <> "" Then
adres = Cells(i, 1).Hyperlinks(1).Address
Set sayfa = CreateObject("Shell.Application")
sayfa.ShellExecute "chrome.exe", adres, "", "", 1
End If
Next
End Sub

Her link için (örn; https://yadi.sk/i/ToWig-pM3MzACW) önce chrome'u açıp, "İNDİR" butonunu tıklayarak dosyayı indiren ve sonrasında chrome'u kapatan bir makro oluşturabilir miyiz?

 

[cumay]

Yardımcı olacak biri yok mudur?

 

[cumay]

Bu işlem çözümsüz mü acaba? Biri bir bilgi verebilir mi?

 

[Asri]

Bu şekilde deneyin.
Linkler A kolonunda alt alta yazılmış olsun.

Dim islem, URL As String
Dim ie As Object
Dim objCollection As Object

Sub menu()
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    For i = 1 To sonsatir
       URL = Cells(i, "A").Value
       Call url_ac
       Call tikla
    Next i
End Sub

Sub bekle()
    With ie
        Do Until .readyState = 4: DoEvents: Loop
        Do While .Busy: DoEvents: Loop
    End With
End Sub

Sub url_ac()

    Set ie = CreateObject("InternetExplorer.Application")
    With ie
      .Navigate URL
      .Visible = 1
    End With

basla:
   Call bekle
   If InStr(ie.document.body.innerText, "İndir") = 0 Then
      GoTo basla
   End If
   
End Sub

Sub tikla()
    Set objCollection = ie.document.getElementsByTagName("button")
    i = 0
    Do While i < objCollection.Length
      If objCollection(i).innerText = "İndir" Then
         objCollection(i).Click
         Exit Do
      End If
      i = i + 1
    Loop
    Application.Wait Now + TimeValue("00:00:03")
    SendKeys "{TAB}{TAB}{ENTER}{ENTER}"
    
    'En uzun sürede inecek dosyanın süresi saniye olarak
    Application.Wait Now + TimeValue("00:00:05")
   
    FindAndTerminate "IExplore.exe"
   
End Sub

Sub FindAndTerminate(ByVal strProcName As String)
    Dim objWMIService, objProcess, colProcess
    Dim strComputer, strList
    strComputer = "."
    Set objWMIService = GetObject("winmgmts:" _
    & "{impersonationLevel=impersonate}!\\" _
    & strComputer & "\root\cimv2")
    Set colProcess = objWMIService.ExecQuery _
    ("Select * from Win32_Process Where Name = '" & strProcName & "'")
    If colProcess.Count > 0 Then
        For Each objProcess In colProcess
            objProcess.Terminate
        Next objProcess
    End If
End Sub

 

[cumay]

Üstad kod için çok teşekkür ederim. Ancak bir iki sorunum var. birincisi (ki düzelttim) URL = Cells(1, "A").Value komutu URL = Cells(i, "A").Value yaptım. i döngüsü için

ikincisi IE objesini CHROME yapmak mümkün mü Explorer da dosya aç kaydet iptal seçeneğinden dolayı dosyayı kaydetmiyor.

 

[Asri]

Üstad kod için çok teşekkür ederim. Ancak bir iki sorunum var. birincisi (ki düzelttim) URL = Cells(1, "A").Value komutu URL = Cells(i, "A").Value yaptım. i döngüsü için

ikincisi IE objesini CHROME yapmak mümkün mü Explorer da dosya aç kaydet iptal seçeneğinden dolayı dosyayı kaydetmiyor.

IE otomatik başlama sağlanamadığı için SENDKEY kullanıldı.
Bu da çok sağlıklı olmadı. Bir ENTER daha ekledim.
Daha öncede çalşıyordu ancak şimdi bu enter ile de download başlıyor.

Chrome ve Firefox gibi tarayıcıları sorunsuz kullanmak için dosya linkinin belli olması gerekiyor. www.siteadi.com/dosya.mp3 gibi.

Selenium gibi alternatif yöntemler var ama ben bile uzak duruyorum : ))

Deneyiniz.