Umbenennen einer Datei

[maninweb]

Hallo,

ich habe Dir das mal komplett umgeschrieben, da bei Dir nun doch einiges an Fehlern und unnötiger Code drin ist.
Du musst dann entsprechend Anpassungen an Deine Gegebenheiten vornehmen. Den Code in ein neues Modul
kopieren und Deine alte Prozedur Prognose umbenennen.

Code:

Option Explicit
 
' API...
 
  Private Declare PtrSafe 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
 
' Konstanten...
 
  Private Const cstFolderArchive    As String = "Archiv"
  Private Const cstFolderDefault    As String = "D:\Downloads\Niko"
 
' Private...
 
  Private Function GetFolder(Default As String, Override As Boolean) As String
   
    Dim r As String
   
'  Übergehen...
   
    If Not Override Then
     
'    Dialog aufrufen...
     
      With Application.FileDialog(msoFileDialogFolderPicker)
       
'      Einstellungen..
       
      .AllowMultiSelect = False
      .Title = "Bitte Ordner wählen"
      .InitialFileName = cstFolderDefault
      .InitialView = msoFileDialogViewThumbnail
      .ButtonName = "OK"
       
'      Anzeigen...
       
        If .Show = -1 Then
         
          r = .SelectedItems(1)
         
        End If
       
      End With
   
    End If
   
'  Standardordner falls abgebrochen oder übergangen...
   
    If Len(r) < 1 Then
   
      r = Default
       
    End If
   
'  Return...
   
    GetFolder = r
   
  End Function
 
  Public Function Unzip(Source As Variant) As String
   
    Dim objShell      As Object
    Dim objSource    As Object
    Dim objTarget    As Object
    Dim objItem      As Object
   
    Dim strResult    As String
    Dim strSeparator  As String
   
    Dim vntFolder    As Variant
   
'  Fehler...
   
    On Error Resume Next
   
'  Initialisieren...
   
    strResult = ""
    strSeparator = Application.PathSeparator
    vntFolder = Left(Source, Len(Source) - Len(Split( _
                StrReverse(Source), strSeparator)(0)))
   
'  Shell..
   
    Set objShell = CreateObject("Shell.Application")
   
'  Prüfen...
   
    If Not objShell Is Nothing Then
     
'    Namespaces...
     
      Set objSource = objShell.Namespace(Source)
      Set objTarget = objShell.Namespace(vntFolder)
     
'    Prüfen...
     
      If Not objSource Is Nothing And _
        Not objTarget Is Nothing Then
       
'      Anzahl...
       
        If objSource.Items.Count > 0 Then
         
'        Erstes Element...
         
          strResult = objSource.Items.Item(0).Name
         
'        Löschen...
         
          If Not UCase(Dir(vntFolder & strSeparator & strResult)) <> _
                UCase(strResult) Then
           
            Kill vntFolder & strSeparator & strResult
           
          End If
         
'        Nicht vorhanden oder erfolgreich gelöscht...
         
          If UCase(Dir(vntFolder & strSeparator & strResult)) <> _
            UCase(strResult) Then
         
            objTarget.CopyHere objSource.Items.Item(0)
           
          End If
         
        End If
       
      End If
     
    End If
   
'  Aufräumen...
   
    Set objTarget = Nothing
    Set objSource = Nothing
    Set objShell = Nothing
   
'  Ergebnis...
   
    Unzip = strResult
   
  End Function
 
' Public...
 
  Public Sub Prognose()
   
    Dim lngError      As Long
    Dim lngResult    As Long
   
    Dim strArchive    As String
    Dim strDate      As String
    Dim strDownload  As String
    Dim strFile      As String
    Dim strFileKML    As String
    Dim strFileText  As String
    Dim strSeparator  As String
    Dim strStation    As String
    Dim strTime      As String
    Dim strUrl        As String
   
'  Initialisieren...
   
    lngError = 0
   
    strDate = Format(Date, "YYYYMMDD") & "09"
    strTime = Format(Time, "hhmmss")
   
    strSeparator = Application.PathSeparator
    strStation = ThisWorkbook.Worksheets("Rechner2").Cells(20, 4).Value
   
'  Prüfen...
   
    If Len(strStation) < 1 Then
     
      lngError = 1
     
    Else
     
'    Ordner abfragen...
     
      strDownload = GetFolder(cstFolderDefault, False)
      strArchive = strDownload & strSeparator & cstFolderArchive
     
'    Existenz prüfen...
     
      If Len(Dir(strDownload, vbDirectory)) > 0 Then
       
'      Existenz vom Archivordner prüfen...
       
        If Len(Dir(strArchive, vbDirectory)) < 1 Then
         
'        Erstellen...
         
          MkDir strArchive
         
'        Prüfen...
         
          If Len(Dir(strArchive, vbDirectory)) < 1 Then
           
            lngError = 3
           
          End If
         
        End If
       
      Else
       
        lngError = 2
       
      End If
   
    End If
   
'  Fehlerprüfung...
   
    If lngError < 1 Then
     
'    Parameter...
     
      strFile = "MOSMIX_L_LATEST_" & strDate & "_" & strStation & "_" & strTime & ".zip"
      strUrl = "https://opendata.dwd.de/weather/local_forecasts/mos/MOSMIX_L/single_stations/" & _
                strStation & "/kml/" & "MOSMIX_L_LATEST_" & strStation & ".kmz"
     
'    Download...
     
      lngResult = 0
      lngResult = URLDownloadToFile(0, strUrl, strDownload & strSeparator & strFile, 0, 0)
     
'    Prüfen...
     
      If lngResult <> 0 Then
       
        lngError = 4
       
      Else
     
'      Existenz...
       
        If UCase(Dir(strDownload & strSeparator & strFile)) <> _
          UCase(strFile) Then
         
          lngError = 4
         
        End If
       
      End If
     
    End If
   
'  Fehlerprüfung...
   
    If lngError < 1 Then
   
'    Kopieren...
     
      FileCopy strDownload & strSeparator & strFile, _
              strArchive & strSeparator & strFile
     
'    Existenz...
     
      If UCase(Dir(strArchive & strSeparator & strFile)) <> _
        UCase(strFile) Then
         
        lngError = 5
       
      Else
       
'      Löschen...
       
        Kill strDownload & strSeparator & strFile
       
      End If
     
    End If
   
'  Fehlerprüfung...
   
    If lngError < 1 Then
     
'    Entpacken...
     
      strFileKML = ""
      strFileKML = Unzip(strArchive & strSeparator & strFile)
     
'    Prüfen...
     
      If Len(strFileKML) > 0 Then
       
'      Archiv löschen...
       
        Kill strArchive & strSeparator & strFile
       
'      Textdatei...
       
        strFileText = Replace(strFileKML, ".kml", ".txt")
       
'      Existenz...
       
        If Not UCase(Dir(strArchive & strSeparator & strFileText)) <> _
              UCase(strFileText) Then
         
          Kill strArchive & strSeparator & strFileText
         
        End If
       
'      Umbenennen...
       
        Name strArchive & strSeparator & strFileKML As _
            strArchive & strSeparator & strFileText
       
      Else
       
        lngError = 6
       
      End If
     
    End If
   
'  Fehlerprüfung...
   
    If lngError < 1 Then
     
'    Importieren...
     
      Application.Workbooks.OpenText _
      Filename:=strArchive & strSeparator & strFileText, _
      Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, _
      TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, _
      Tab:=True, Semicolon:=False, Comma:=False, Space:=True, _
      Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _
      Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), _
      TrailingMinusNumbers:=True
     
'    Kopieren...
'
'    Ggf. ThisWorkbook durch Application.Workbooks("NAME") ersetzen
     
      Application.Workbooks(Application.Workbooks.Count).Worksheets(1).Copy _
      After:=ThisWorkbook.Worksheets(9)
     
'    Schließen...
     
      Application.Workbooks(Application.Workbooks.Count).Close False
     
    End If
   
'  Fehlermeldungen...
   
    If lngError > 0 Then
     
      Select Case lngError
       
        Case 1
         
          MsgBox "Keine Station angegeben.", vbExclamation + vbOKOnly
         
        Case 2
         
          MsgBox "Zielordner nicht gefunden.", vbExclamation + vbOKOnly
         
        Case 3
         
          MsgBox "Archivordner konnte nicht erstellt werden.", vbExclamation + vbOKOnly
         
        Case 4
         
          MsgBox "Download ist fehlgeschlagen.", vbExclamation + vbOKOnly
         
        Case 5
         
          MsgBox "Downloaddatei kann nicht in den Archivordner kopiert werden.", vbExclamation + vbOKOnly
         
        Case 6
         
          MsgBox "Das Archiv konnte nicht entpackt werden.", vbExclamation + vbOKOnly
         
        Case Else
       
      End Select
     
    End If
   
  End Sub

Gruß