İnternet Üzerinden Dosya Kaydetmek

[baydeniro]

Merhaba arkadaşlar. Makro kodu ile internet üzerinde bulunan (erişimi sadece firma çalışanlarına açık olan) dosyayı açabiliyorum. Ancak bu dosyayı açmadan kopyalamayı başaramadım. Bu teknik olarak mümkün müdür ?

 

[Zeki Gürsoy]

Merhaba;

Dosyayı indirmeniz gerekir.

With CreateObject("MSXML2.XMLHTTP")
    .Open "get", "http://SB/AKDENIZ/?????.xls", False
    .send
    bnr = .responseStream
End With

Open "C:\Users\finance\Desktop\???.xls" For Binary As #1
    Put #1, , bnr
Close #1

 

[Murat OSMA]

Daha önce hazırladığım bir dosya vardı, onu ekliyorum. Belki bir faydası olur..

Sub Evn()
    Dim i As Integer
    Dim WShel As Object
    Dim a As String

    basla = Timer
    Set WShel = CreateObject("WScript.Shell")
    a = WShel.SpecialFolders("Desktop")

    Const MsgText = "Dosyalar İndirilsin mi ?"
    Const MsgHdr = "İnidiriliyor..."
    If MsgBox(MsgText, vbYesNo Or vbMsgBoxRtlReading Or vbExclamation, MsgHdr) _
        = vbYes Then
    MkDir (a & "\Evn Download")
    For i = 2 To 7
    Cells(i, "C").Value = Right(Cells(i, "A"), 4)
    URL$ = Cells(i, "A").Value
    dosya$ = a & "\Evn Download" & "\" & Cells(i, "B").Value & "." & Cells(i, "c").Value
    DownloadFile URL$, dosya$
    'CreateObject("Wscript.shell").Run """" & dosya$ & """" - Dosyayı çalıştır...
    Next i
    End If
    
    bitir = Timer - basla
    MsgBox "İndirme işlemi " & Format(bitir, "00:00:00.00") & " sürede tamamlanmıştır. ", _
     vbInformation + vbMsgBoxRtlReading, "Www.ExcelVBA.Net"
    i = Empty
    a = vbNullString
    Set WShel = Nothing
End Sub

Function DownloadFile(ByVal URL$, ByVal LocalPath$) As Boolean
    Dim XMLHTTP, ADOStream, FileName
    On Error Resume Next: Kill LocalPath$
    Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
    XMLHTTP.Open "GET", Replace(URL$, "\", "/"), "False"
    XMLHTTP.send
    If XMLHTTP.statustext = "OK" Then
    Set ADOStream = CreateObject("ADODB.Stream")
    ADOStream.Type = 1: ADOStream.Open
    ADOStream.Write XMLHTTP.responseBody
    ADOStream.SaveToFile LocalPath$, 2
    ADOStream.Close: Set ADOStream = Nothing
    DownloadFile = True
    Else
    MsgBox "Bağlantı sağlanamadı", vbInformation, "Hata !"
    End If
    Set XMLHTTP = Nothing
End Function

 

[baydeniro]

Sayın Zeki Gürsoy ilginize çok teşekkür ederim. Kod bnr = .responseStream aşamasında Type mismatch uyarsı çıkarak takılıyor.

 

[baydeniro]

Sayın Murat Osma ilginize çok teşekkür ederim. Kodda internet adredsini nereye yazmam gerektiğini çözemedim. Mevcut hali ile çalıştırdım C3:C7 hücrelerine ALYA, DRUM, HİYE, ARİS yazdı.

 

[Murat OSMA]

URL$ = Cells(i, "A").Value

İndireceğiniz dosya adreslerini A sütununa yazabilirsiniz.

 

[baydeniro]

Sayın Murat Osma teşekkür ederim. Size de zahmet veriyorum. Dosyanın linkini A1 hücresine kapyalaım. Bir kademe daha ilerledim. İlgili Katalog altına Evn adı ile bir alt katalog açıyor ancak içinde dosya yok.

 

[baydeniro]

Sayın Murat Osma çok teşekkür ederim. Sorunu çözdüm. emeğinize, aklınıza sağlık, Allah sizden razı olsun, sağlıcakla kalın.

 

[Murat OSMA]

Âmîn... cümlemizden râzı olsun...
Yardımcı olabildiğime sevindim..

Hoşça kalın !!!

 

[baydeniro]

Allah sizlerden gerçekten razı olsun, o kadar güzel bilgiler paylaşıyor ve yardım ediyorsunuz ki eminim Türkiye'nin üretim ve rekabet gücü artıyordur. Dosyaları Desktop'a kopyalarken sorun olmuyor. Ancak şu şekilde kopyalamayı gerçekleştirmiyor. Bu bir teknik engel mi ? yoksa ben mi bir hata yapıyor olabilirim ?

C:\Users\finance\Documents\

 

[turan1971]

Allah sizlerden gerçekten razı olsun, o kadar güzel bilgiler paylaşıyor ve yardım ediyorsunuz ki eminim Türkiye'nin üretim ve rekabet gücü artıyordur. Dosyaları Desktop'a kopyalarken sorun olmuyor. Ancak şu şekilde kopyalamayı gerçekleştirmiyor. Bu bir teknik engel mi ? yoksa ben mi bir hata yapıyor olabilirim ?

C:\Users\finance\Documents\

Murat bey'in aşağıdaki kodunu diğeri ile değiştirin...
a = WShel.SpecialFolders("Desktop")
a = WShel.SpecialFolders("My Documents")

yada yukardaki kodu şu şekilde yazın...
a="C:\Users\finance\Documents\"

 

[baydeniro]

Çok teşekkürler sayın turan1971.

 

[Murat OSMA]

Şu satırı;
Set WShel = CreateObject("WScript.Shell")
ve şu satırı silin;
MkDir (a & "\Evn Download")

Bu kodu;
a = WShel.SpecialFolders("Desktop")
şöyle yapın;
a = "C:\Users\finance\Documents\"

Şu satırı da;
dosya$ = a & "\Evn Download" & "\" & Cells(i, "B").Value & "." & Cells(i, "c").Value
bu şekilde değiştirin;
dosya$ = a & "\" & Cells(i, "B").Value & "." & Cells(i, "c").Value

Sanırım şimdi düzelecektir...

 

[baydeniro]

Tekrar çok teşekkür ederim sayın Murat Osma.

 

[Murat OSMA]

Rica ederim Serdar Bey, iyi akşamlar...