Code VBA Downloads File Từ Web Về Máy Tính

Kiều Mạnh · 23/6/15

Hiện Mình đang sử dụng code sau của GPE Tải File từ Internet về hiên tại đang sử dụng tốt ...nhưng có một điều hơi bất tiện là mỗi lần thay đổi File tải về là phải sửa lại code ...cụ thể là sửa lại phần mở rộng của File VD như: *.rar, *.doc, *.xlsx, *.xlsb
Vì vậy mình úp lên nhờ các Bạn xem có cách nào khác mà chỉ nhập Link vào [B1] và chạy code là tải file về được không .... không cần biết file đó là Excel hay rar....
Code Downloads File

PHP:

Private Declare Function URLDownloadToFile Lib "urlmon" Alias _"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Chạy Sub Này
Sub FileDownloads()
    Dim StrSavePath As String, Ret As Long
    StrSavePath = ThisWorkbook.Path & "\" & "FileDowloads.rar"    ''<- Ten File Luu
    Ret = URLDownloadToFile(0, [B1], StrSavePath, 0, 0)           ''<- Link Tai File Tai [B1]
End Sub

Xin Cảm Ơn Các Bạn

befaint · 23/6/15

Tôi không biết cài này... nhưng tìm trên mạng có 1 website làm chi tiết cái này. Đã test thử và chạy ngon lành.
Có file đính kèm sẵn.
Link nguồn:
http://www.myengineeringworld.net/2013/11/excel-vba-download-internet-files.html

Kiều Mạnh · 23/6/15

befaint đã viết:
Tôi không biết cài này... nhưng tìm trên mạng có 1 website làm chi tiết cái này. Đã test thử và chạy ngon lành.
Có file đính kèm sẵn.
Link nguồn:
http://www.myengineeringworld.net/2013/11/excel-vba-download-internet-files.html

Tuyệt Vời đó Bạn Cảm ơn Bạn nhiều

ndu96081631 · 23/6/15

befaint đã viết:
Tôi không biết cài này... nhưng tìm trên mạng có 1 website làm chi tiết cái này. Đã test thử và chạy ngon lành.
Có file đính kèm sẵn.
Link nguồn:
http://www.myengineeringworld.net/2013/11/excel-vba-download-internet-files.html

Thấy code này viết dở ẹc! Ai rảnh sửa lại cho gọn và đẹp giùm cái...
Đọc code, thấy cái gì mà WorksheetFunction.Find rồi .Substitute... từa lưa hột dưa cả lên
(tay này hình như hổng biết hàm InStr và Replace trong VBA thì phải)
--------------
Còn tôi thì thích cái này hơn:

Mã:

Private Sub URL2File(ByVal URL As String, ByVal Folder2Save As String)
  Dim objReq As Object
  Dim FileName As String, path As String
  If Right(Folder2Save, 1) <> "\" Then Folder2Save = Folder2Save & "\"
  FileName = Mid(URL, InStrRev(URL, "/") + 1, Len(URL))
  path = Folder2Save & FileName
  Set objReq = CreateObject("MSXML2.XMLHTTP")
  objReq.Open "GET", URL, False
  objReq.send
  If objReq.Status = 200 Then
    With CreateObject("ADODB.Stream")
      .Open
      .Type = 1
      .Write objReq.ResponseBody
      .Position = 0
      .SaveToFile path, 2
      .Close
    End With
  End If
  Set objReq = Nothing
End Sub

Ví dụ áp dụng để download 1 file, chẳng hạn là 1 file nhạc từ mp3.zing.vn:

Mã:

Sub Test()
  Dim URL As String, Folder2Save As String
  URL = "http://stream2.hot2.cache11.vcdn.vn/fsfsdfdsfdserwrwq3/f89c6c4f2d64a98ce5dfdc06d81c89fb/558989f8/2011/07/08/d/c/dcf6ee06080c030069f791dd7d63857a.mp3"
  Folder2Save = ThisWorkbook.path
  URL2File URL, Folder2Save
End Sub

Kiều Mạnh · 23/6/15

ndu96081631 đã viết:
Thấy code này viết dở ẹc! Ai rảnh sửa lại cho gọn và đẹp giùm cái...
Đọc code, thấy cái gì mà WorksheetFunction.Find rồi .Substitute... từa lưa hột dưa cả lên
(tay này hình như hổng biết hàm InStr và Replace trong VBA thì phải)
--------------
Còn tôi thì thích cái này hơn:

Mã:

Private Sub URL2File(ByVal URL As String, ByVal Folder2Save As String) Dim objReq As Object Dim FileName As String, path As String If Right(Folder2Save, 1) <> "\" Then Folder2Save = Folder2Save & "\" FileName = Mid(URL, InStrRev(URL, "/") + 1, Len(URL)) path = Folder2Save & FileName Set objReq = CreateObject("MSXML2.XMLHTTP") objReq.Open "GET", URL, False objReq.send If objReq.Status = 200 Then With CreateObject("ADODB.Stream") .Open .Type = 1 .Write objReq.ResponseBody .Position = 0 .SaveToFile path, 2 .Close End With End If Set objReq = Nothing End Sub

Ví dụ áp dụng để download 1 file, chẳng hạn là 1 file nhạc từ mp3.zing.vn:

Mã:

Sub Test() Dim URL As String, Folder2Save As String URL = "http://stream2.hot2.cache11.vcdn.vn/fsfsdfdsfdserwrwq3/f89c6c4f2d64a98ce5dfdc06d81c89fb/558989f8/2011/07/08/d/c/dcf6ee06080c030069f791dd7d63857a.mp3" Folder2Save = ThisWorkbook.path URL2File URL, Folder2Save End Sub

Trên cả tuyệt vời đó Anh Code gọn nếu thích chế biến lại Sub test thành các kiểu
Cảm ơn Anh

kuldokk · 24/6/15

ndu96081631 đã viết:
Thấy code này viết dở ẹc! Ai rảnh sửa lại cho gọn và đẹp giùm cái...
Đọc code, thấy cái gì mà WorksheetFunction.Find rồi .Substitute... từa lưa hột dưa cả lên
(tay này hình như hổng biết hàm InStr và Replace trong VBA thì phải)
--------------
Còn tôi thì thích cái này hơn:

Mã:

Private Sub URL2File(ByVal URL As String, ByVal Folder2Save As String) Dim objReq As Object Dim FileName As String, path As String If Right(Folder2Save, 1) <> "\" Then Folder2Save = Folder2Save & "\" FileName = Mid(URL, InStrRev(URL, "/") + 1, Len(URL)) path = Folder2Save & FileName Set objReq = CreateObject("MSXML2.XMLHTTP") objReq.Open "GET", URL, False objReq.send If objReq.Status = 200 Then With CreateObject("ADODB.Stream") .Open .Type = 1 .Write objReq.ResponseBody .Position = 0 .SaveToFile path, 2 .Close End With End If Set objReq = Nothing End Sub

Ví dụ áp dụng để download 1 file, chẳng hạn là 1 file nhạc từ mp3.zing.vn:

Mã:

Sub Test() Dim URL As String, Folder2Save As String URL = "http://stream2.hot2.cache11.vcdn.vn/fsfsdfdsfdserwrwq3/f89c6c4f2d64a98ce5dfdc06d81c89fb/558989f8/2011/07/08/d/c/dcf6ee06080c030069f791dd7d63857a.mp3" Folder2Save = ThisWorkbook.path URL2File URL, Folder2Save End Sub

Đọc qua bài từ nguồn đó thì thấy là code đó viết dài thật, nhưng dài là do comments, bẫy lỗi và ... mục đích khác.

ndu96081631 · 24/6/15

kuldokk đã viết:
Đọc qua bài từ nguồn đó thì thấy là code đó viết dài thật, nhưng dài là do comments, bẫy lỗi và ... mục đích khác.

Comment, bẫy lỗi là tốt nhưng ý tôi không nói đến cái này. Bạn đọc kỹ code sẽ thấy cái "dở ẹc" nó nằm ở chỗ nào
(thật ra code bài 2 và bài 1 là như nhau)

Kiều Mạnh · 24/6/15

Code Bài #4 hay thiệt Tải file về rồi bấm tải tới tải lui mà ko lỗi và không Rename thành file khác
Kiểu này vọc tiếp làm Internet Download Manager quá --=0

ndu96081631 · 24/6/15

kieu manh đã viết:
Kiểu này vọc tiếp làm Internet Download Manager quá

Giỡn chơi không! IDM là chương trình download file thuộc hạng siêu sao hiện nay. Trình độ cò con như ta làm sao đấu lại

Kiều Mạnh · 24/6/15

ndu96081631 đã viết:
Giỡn chơi không! IDM là chương trình download file thuộc hạng siêu sao hiện nay. Trình độ cò con như ta làm sao đấu lại

Thì Em cứ hoạch không tưởng xa vời vậy để mà Lấy hứng thú vọc nghiên cứu tiếp chứ

...Không lẻ bằng lòng với hiện tại một ngày nào đó một phút nhìn lại Mình thì thấy tụt hậu mất rồi....

Mơ ước tương lai xa xăm để mà hướng tới là tốt chứ Anh
Mặc dù biết không làm được nhưng vẫn Mơ --=0

minh090506 · 12/12/15

Đúng vấn đề em đang cần ạ. quá hay.

trchau · 4/8/16

Các bạn đã thử với file excel chưa? tôi lấy code của anh NDU ở bài 4, thay link của tôi:
http://www.mediafire.com/download/b1f08fq2a4b9uuw/Test.xlsm
chạy code download file về nhưng không mở được mà báo lỗi: Excel cannot open file ... because the file format or tile extension is not valid... (đính kèm file excel download về bị lỗi)

Thông tin thêm:
+ Nếu download trực tiếp từ link thì file mở được
+ Đổi đuôi file thành .xls thì mở lên được (file tạo ra từ excell 2007, không phải từ excel 2003), nhưng thấy hiện tượng: mất dữ liệu gốc, mất hết các sheet chỉ có 1 sheet có tên sheet bị đặt lại giống tên file, trên đó ghi dữ liệu gì đó thông báo về định dạng không mở được…
+ Thử nhiều lần vẫn vậy.
Tình trạng giống bài này: http://www.giaiphapexcel.com/forum/showthread.php?55209-Không-mở-được-file-excle

Bạn nào biết nguyên nhân xin chỉ tôi cách khắc phục, cảm ơn.

ndu96081631 · 5/8/16

trchau đã viết:
Các bạn đã thử với file excel chưa? tôi lấy code của anh NDU ở bài 4, thay link của tôi:
http://www.mediafire.com/download/b1f08fq2a4b9uuw/Test.xlsm
chạy code download file về nhưng không mở được mà báo lỗi: Excel cannot open file ... because the file format or tile extension is not valid... (đính kèm file excel download về bị lỗi)

Thông tin thêm:
+ Nếu download trực tiếp từ link thì file mở được
+ Đổi đuôi file thành .xls thì mở lên được (file tạo ra từ excell 2007, không phải từ excel 2003), nhưng thấy hiện tượng: mất dữ liệu gốc, mất hết các sheet chỉ có 1 sheet có tên sheet bị đặt lại giống tên file, trên đó ghi dữ liệu gì đó thông báo về định dạng không mở được…
+ Thử nhiều lần vẫn vậy.
Tình trạng giống bài này: http://www.giaiphapexcel.com/forum/showthread.php?55209-Không-mở-được-file-excle

Bạn nào biết nguyên nhân xin chỉ tôi cách khắc phục, cảm ơn.

Bởi vì link bạn đưa ở trên không phải là direct link mà chỉ là share link mà thôi
Bạn để ý nếu download file này bằng IDM thì bạn sẽ nhận được:

Cái dòng link trong khung đỏ ở hình trên mới là link trực tiếp
Vậy áp dụng vào code bạn phải viết thế này:

Mã:

Sub Test()
  Dim URL As String, Folder2Save As String
  URL = "http://download1351.mediafire.com/qx6nwhw5t4ag/b1f08fq2a4b9uuw/Test.xlsm"  ''<--- direct link
  Folder2Save = ThisWorkbook.path
  URL2File URL, Folder2Save
End Sub

Thử xem

doveandrose · 6/8/16

ndu96081631 đã viết:
Bởi vì link bạn đưa ở trên không phải là direct link mà chỉ là share link mà thôi
Bạn để ý nếu download file này bằng IDM thì bạn sẽ nhận được:

View attachment 163374

Cái dòng link trong khung đỏ ở hình trên mới là link trực tiếp
Vậy áp dụng vào code bạn phải viết thế này:

Mã:

Sub Test() Dim URL As String, Folder2Save As String URL = "http://download1351.mediafire.com/qx6nwhw5t4ag/b1f08fq2a4b9uuw/Test.xlsm" ''<--- direct link Folder2Save = ThisWorkbook.path URL2File URL, Folder2Save End Sub

Thử xem

dạ có thử rồi , mà chắc số em bị xui , cứ anh NDU viết code là em không chạy được . hu hu !$@!!

ndu96081631 · 6/8/16

doveandrose đã viết:
dạ có thử rồi , mà chắc số em bị xui , cứ anh NDU viết code là em không chạy được . hu hu

Chắc lại liên quan đến 32 bit, 64 bit gì đó.. tôi không biết đâu. Bạn tự sửa đi (máy tôi chạy ổn)

doveandrose · 6/8/16

ndu96081631 đã viết:
Chắc lại liên quan đến 32 bit, 64 bit gì đó.. tôi không biết đâu. Bạn tự sửa đi (máy tôi chạy ổn)

không phải đâu anh , giữa link để xem với link để down có 1 phần khác nhau đó

Mã:

http://www.mediafire.com/download/b1f08fq2a4b9uuw/Test.xlsm
http://download1351.mediafire.com/[COLOR=#ff0000][SIZE=4][B]qx6nwhw5t4ag[/B][/SIZE][/COLOR]/b1f08fq2a4b9uuw/Test.xlsm

phần này mỗi máy mỗi khác thí dụ trên máy em nó là

Mã:

http://download1351.mediafire.com/[COLOR=#ff0000][SIZE=4][B]578275vopgng[/B][/SIZE][/COLOR]/b1f08fq2a4b9uuw/Test.xlsm

vả lại làm sao lấy được cái link download chắc phải có ...cách khác không lẽ bắt người ta copy từ IDM hay sao ? --=0

. Đừng bắt em phải đến đây đăng kí để biết rõ chi tiết nha anh . hi hi --=0

ndu96081631 · 6/8/16

doveandrose đã viết:
chắc phải có ...cách khác không lẽ bắt người ta copy từ IDM hay sao ? . Đừng bắt em phải đến đây đăng kí để biết rõ chi tiết nha anh . hi hi

Khi gửi bài 13 tôi cũng đã nghĩ đến vụ này rồi, có điều... thì thôi mọi người cứ google tìm giải pháp vậy (làm sao lấy được direct link)

doveandrose · 6/8/16

ndu96081631 đã viết:
Khi gửi bài 13 tôi cũng đã nghĩ đến vụ này rồi, có điều... thì thôi mọi người cứ google tìm giải pháp vậy (làm sao lấy được direct link)

Anh "lì" quá à , dụ mãi mà không được anh giúp . Em viết thử cái này , anh xem có chạy trên máy anh không ?

Mã:

Public Sub hellTest()
Dim URL As String, Folder2Save As String
URL = "http://www.mediafire.com/download/b1f08fq2a4b9uuw/Test.xlsm"
Folder2Save = ThisWorkbook.path
getMediafireUrlOnly URL, Folder2Save
End Sub


Private Sub getMediafireUrlOnly(ByVal mfLink As String, ByVal Folder2Save As String)
Dim req As Object, lPos As Long, resp As String
Set req = CreateObject("MSXML2.XMLHTTP")
req.Open "GET", mfLink, False
req.send
If req.Status = 200 Then
    resp = req.responseText
    lPos = InStr(resp, "http://download")
    resp = Mid(resp, lPos, InStr(lPos, resp, """") - lPos)
    If InStr(resp, "mediafire.com") > 0 Then
        URL2File resp, Folder2Save
    Else
        MsgBox "rat' tiec' chuc' may man' lan` sau"
    End If
End If
Set req = Nothing
End Sub

ndu96081631 · 6/8/16

doveandrose đã viết:
Anh "lì" quá à , dụ mãi mà không được anh giúp

Thì mình cũng đang.. dụ.. người ta thôi --=0

Kiều Mạnh · 6/8/16

doveandrose đã viết:

Anh "lì" quá à , dụ mãi mà không được anh giúp . Em viết thử cái này , anh xem có chạy trên máy anh không ?

Mã:

Public Sub hellTest()
Dim URL As String, Folder2Save As String
URL = "http://www.mediafire.com/download/b1f08fq2a4b9uuw/Test.xlsm"
Folder2Save = ThisWorkbook.path
getMediafireUrlOnly URL, Folder2Save
End Sub


Private Sub getMediafireUrlOnly(ByVal mfLink As String, ByVal Folder2Save As String)
Dim req As Object, lPos As Long, resp As String
Set req = CreateObject("MSXML2.XMLHTTP")
req.Open "GET", mfLink, False
req.send
If req.Status = 200 Then
    resp = req.responseText
    lPos = InStr(resp, "http://download")
    resp = Mid(resp, lPos, InStr(lPos, resp, """") - lPos)
    If InStr(resp, "mediafire.com") > 0 Then
        URL2File resp, Folder2Save
    Else
        MsgBox "rat' tiec' chuc' may man' lan` sau"
    End If
End If
Set req = Nothing
End Sub

Mình cũng ko hiểu lắm ... mà sao link tải trực tiếp MediaFile nó hay thay đổi lắm 1 - 2h là nó lại thay đổi ...phải chăng là ngăn ko cho ai đó sử dụng chùa ...

Code VBA Downloads File Từ Web Về Máy Tính

I don't program, I beat code into submission!!!

|||||||||||||

File đính kèm

I don't program, I beat code into submission!!!

Huyền thoại GPE

File đính kèm

I don't program, I beat code into submission!!!

Thành viên hoạt động

Huyền thoại GPE

I don't program, I beat code into submission!!!

Huyền thoại GPE

I don't program, I beat code into submission!!!

Thành viên mới

Thành viên mới

File đính kèm

Huyền thoại GPE

hello

Huyền thoại GPE

hello

Huyền thoại GPE

hello

Huyền thoại GPE

I don't program, I beat code into submission!!!

Facebook

Group