Massen-Download über url

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
ich würde das so machen.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
    ByVal DirPath As String) As Long
Private Declare Function URLDownloadToFile Lib "urlmon.dll" Alias "URLDownloadToFileA" ( _
    ByVal pCaller As Long, _
    ByVal szURL As String, _
    ByVal szFileName As String, _
    ByVal dwReserved As Long, _
    ByVal lpfnCB As Long) As Long
Private Declare Function InternetDial Lib "wininet.dll" ( _
    ByVal hwndParent As Long, _
    ByVal lpszConiID As String, _
    ByVal dwFlags As Long, _
    ByRef hCon As Long, _
    ByVal dwReserved As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function RasEnumConnections Lib "rasapi32.dll" Alias "RasEnumConnectionsA" ( _
    lpRasCon As Any, lpcb As Long, _
    lpcConnections As Long) As Long
Private Declare Function RasHangUp Lib "rasapi32.dll" Alias "RasHangUpA" ( _
    ByVal hRasConn As Long) As Long
Private Declare Function InternetGetConnectedState Lib "wininet.dll" ( _
    ByRef lpSFlags As Long, _
    ByVal dwReserved As Long) As Long

Private Const GC_CLASSNAMEMSEXCEL = "XLMAIN"
Private Const DIAL_FORCE_ONLINE = 1&
Private Const DIAL_FORCE_UNATTENDED = 2&
Private Const RAS_MAXENTRYNAME = 256&
Private Const RAS_MAXDEVICETYPE = 16&
Private Const RAS_MAXDEVICENAME = 32&
Private Const MAX_FILL = 96&
Private Const NO_ERROR = 0&

Private Type RASType
    dwSize As Long
    hRasCon As Long
    szEntryName(RAS_MAXENTRYNAME) As Byte
    szDeviceType(RAS_MAXDEVICETYPE) As Byte
    szDeviceName(RAS_MAXDEVICENAME) As Byte
    dwFill(MAX_FILL) As Byte
End Type

Public Sub prcDownload()
    Const STR_PATH = "C:\testordner\"
    Dim udtRAS(255) As RASType
    Dim strDownloadFilename As String, strFilename As String
    Dim lngNumBytes As Long, lngConnections As Long, lngReturn As Long
    Dim lngRow As Long, lngCount As Long
    Dim blnReturn As Boolean, blnOnline As Boolean
    On Error GoTo exit_err
    If Not Cbool(MakeSureDirectoryPathExists(STR_PATH)) Then _
        Err.Raise Number:=vbObjectError + 0, Description:= _
        "Fehler beim erstellen des Ordners."
    If Not Cbool(InternetGetConnectedState(0&, 0&)) Then
        blnReturn = RASConnect(FindWindow(GC_CLASSNAMEMSEXCEL, _
            Application.Caption), "", True)
        If Not blnReturn Then Err.Raise Number:=vbObjectError + 1, Description:= _
            "Internetverbindung konnte nicht erstellt werden."
    Else
        blnOnline = True
    End If
    For lngRow = 1 To Cells(Rows.Count, 3).End(xlUp).Row
        strFilename = StrReverse(Mid$(StrReverse(Cells(lngRow, 3).Text), 1, _
            InStr(1, StrReverse(Cells(lngRow, 3).Text), "/") - 1))
        strFilename = Left$(strFilename, Len(strFilename) - 4)
        strDownloadFilename = STR_PATH & strFilename & Right$(Cells(lngRow, 3).Text, 4)
        If Dir$(strDownloadFilename) <> "" Then
            Select Case MsgBox("Datei " & strDownloadFilename & _
                        " existiert. Überschreiben?", vbQuestion + vbYesNoCancel, "Abfrage")
                Case vbCancel: Exit For
                Case vbNo
                    lngCount = 0
                    Do
                        strDownloadFilename = STR_PATH & strFilename & _
                            "(" & CStr(lngCount) & ")" & Right$(Cells(lngRow, 3).Text, 4)
                        lngCount = lngCount + 1
                    Loop While Dir$(strDownloadFilename) <> ""
            End Select
        End If
        lngReturn = URLDownloadToFile(0&, Cells(lngRow, 3).Text, _
            strDownloadFilename, 0&, 0&)
        If lngReturn <> NO_ERROR Then Cells(lngRow, 3).Interior.ColorIndex = 3
    Next
    If Not blnOnline Then
        udtRAS(0).dwSize = 412&
        lngNumBytes = 256& * udtRAS(0).dwSize
        RasEnumConnections udtRAS(0), lngNumBytes, lngConnections
        If lngConnections = 0 Then
            Err.Raise Number:=vbObjectError + 2, Description:= _
                "Fehler beim trennen der Internetverbindung."
        Else
            RasHangUp ByVal udtRAS(0).hRasCon
        End If
    End If
    Exit Sub
    exit_err:
    MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, 16, "Fehler"
End Sub

Private Function RASConnect( _
        ByVal hWnd As Long, _
        Optional ByVal DFÜName As String, _
        Optional ByVal AutoStart As Boolean) As Boolean
    Dim conID As Long
    InternetDial hWnd, DFÜName, IIf(AutoStart, _
        DIAL_FORCE_UNATTENDED, DIAL_FORCE_ONLINE), conID, 0
    RASConnect = (conID <> 0)
End Function

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread