Internet - Dateien / Files - Download....

Frage / Question: Ich habe zwei Spalten. In der ersten Spalte steht ein Link zu den Dateien im Internet die ich downloaden will. In der zweiten Spalte der Name den die Datei erhalten soll. Basically what I have is two columns. The first has a url I can click on, which sends me to a download link that automatically brings up the Save As (Windows 7) box. The second column contains the name I would like the file to be.

Hier noch eine Beispieldatei / Here's a sample file: Internet - Dateien / Files - Download....

Option Explicit
Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
Private Declare Function DeleteUrlCacheEntry Lib "wininet" Alias _
    "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
Private Declare Function PathFileExists Lib "shlwapi.dll" _
    Alias "PathFileExistsA" (ByVal pszPath As String) As Long
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
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 11.12.2012 
' Purpose   : Drag files from the Internet - Dateien aus dem Internet laden 
'-------------------------------------------------------------------------- 
Public Sub Main()
    Dim strFile As String
    Dim strPath As String
    Dim lngResult As Long
    Dim lngLastRow As Long
    Dim wksSheet As Worksheet
    Dim strURL As String
    On Error GoTo Fin
    With ThisWorkbook
        .Worksheets("Sheet2").Visible = -1 ' = xlVisible 
        .Worksheets("Sheet1").Visible = 0 ' = xlHidden 
    End With
    Application.ScreenUpdating = False
    Set wksSheet = ThisWorkbook.Worksheets("Sheet1") 'adapt 
    With wksSheet
        strPath = .Range("A1").Text
        strPath = IIf(Right(strPath, 1) <> "\", strPath & "\", strPath)
        lngLastRow = IIf(IsEmpty(.Range("B" & .Rows.Count)), _
            .Range("B" & .Rows.Count).End(xlUp).Row, .Rows.Count)
        If Not IsFilePath(strPath) Then MakeSureDirectoryPathExists strPath
        For lngLastRow = 1 To lngLastRow
            strURL = .Cells(lngLastRow, 2).Text
            strFile = .Cells(lngLastRow, 3).Text
            Call DeleteUrlCacheEntry(strURL)
            lngResult = URLDownloadToFile(0, strURL, strPath & strFile, 0, 0)
        Next lngLastRow
    End With
    Shell "Explorer.exe /E," & strPath, vbNormalFocus
Fin:
    With ThisWorkbook
        .Worksheets("Sheet1").Visible = -1 ' = xlVisible 
        .Worksheets("Sheet2").Visible = 2 ' = xlSheetVeriHidden 
    End With
    Application.ScreenUpdating = True
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function IsFilePath(strPath As String) As Boolean
    IsFilePath = CBool(PathFileExists(strPath))
End Function

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...