22.11.2019, 22:01
Danke für den Tipp, ich habe aufjedenfall neue Befehle kennengelertn. Leider funktioniert auch dieser Code nicht fehlerfrei denn diesmal bekomm ich den Fehler : "Laufzeitfehler 70: Zugriff verweigert", was aber auch wieder komisch ist, dass durch nochmaliges Fortsetzen des Codes der Fehler wieder ignoriert wird und der Code bis zum Ende wie gewünscht weiter läuft.
Hier ist mein gesamter Code, vielleicht liegt ja auch irgendwo anders das Problem.
Dim DateiName As String
Dim Zeit1 As Date
Dim Zeit2 As String
Dim Datum1 As Date
Dim Datum2 As String
Dim dieUrl As String
Dim DateiPfadzip As String
Dim myResult
Dim StationsID As String
Dim Zählen1 As Integer
Dim Zählen2 As Integer
Dim Zählen3 As Integer
Dim Zählen4 As Integer
Dim Zählen5 As Integer
Dim strFileName As String
Dim DateiExist As String
Dim DateiNameZip As String
Dim DateiNameTxt As String
Dim Name As String
Dim Test As String
Dim DownloadOrdner As String
Dim Pfad As String
Dim NameUrsprung As String
Dim NameZiel As String
Dim Laufdatei As String
Dim ArchivOrdner As String
Option Explicit
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
Sub Prognose()
Datum1 = Date 'aktuelles Datum wird in einer Datum Variable gespeichert
Datum2 = Format(Datum1, "YYYYMMDD" & "09") 'aktuelles Datum wird in einem String gespeichert
StationsID = Sheets("Rechner2").Cells(20, 4) 'Die StationsId wird in einer Variable gespeichert
Zeit1 = Format(Now, "h:mm
s") 'aktuele Uhrzeit wird in einer Zeit Variable gespeichert
Zeit2 = Format(Zeit1, "hmmss") 'aktuele Uhrzeit wird in einem String gespeichert
Call GetExcelfolder
'DownloadOrdner = "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\"
Do
Zählen1 = Zählen1 + 1
Loop Until DownloadOrdner <> ""
Call Ordner
Call Download
Do
Zählen2 = Zählen2 + 1
DateiExist = Dir(DownloadOrdner)
DateiNameZip = DateiExist
Loop Until DateiExist <> ""
Name DownloadOrdner & DateiNameZip As ArchivOrdner & DateiNameZip
Do
Zählen3 = Zählen3 + 1
Loop Until Dir(ArchivOrdner & DateiExist) <> ""
Call Packen
Do
DateiExist = ""
DateiExist = Dir(DownloadOrdner)
DateiNameTxt = DateiExist
Zählen4 = Zählen4 + 1
Loop Until DateiExist <> ""
Call Umbenennen
DateiExist = ""
Do
Zählen5 = Zählen5 + 1
DateiExist = Dir(DownloadOrdner)
DateiNameTxt = DateiExist
Loop Until DateiExist = DateiName & ".txt"
Call Importieren
Call Sheetadd
Name DownloadOrdner & DateiNameTxt As ArchivOrdner & DateiName & Zeit2 & ".txt"
End
End Sub
Public Sub Download()
dieUrl = "https://opendata.dwd.de/weather/local_forecasts/mos/MOSMIX_L/single_stations/" & StationsID & "/kml/MOSMIX_L_LATEST_" & StationsID & ".kmz"
DateiPfadzip = DownloadOrdner & "\MOSMIX_L_LATEST_" & Datum2 & "_" & StationsID & "_" & Zeit2 & ".zip"
myResult = URLDownloadToFile(0, dieUrl, DateiPfadzip, 0, 0)
End Sub
Sub Packen()
Pfad = "C:\Programme\WinRAR\WinRAR.exe e " & ArchivOrdner & DateiExist & " " & DownloadOrdner
Shell (Pfad)
End Sub
Public Sub Umbenennen()
Do
NameUrsprung = DownloadOrdner & DateiExist
Loop Until NameUrsprung <> ""
DateiName = Left(DateiExist, Len(DateiExist) - 4)
Do
NameZiel = DownloadOrdner & DateiName & ".txt"
Loop Until NameZiel <> ""
FileCopy NameUrsprung, NameZiel
Kill NameUrsprung
'FileCopy "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\MOSMIX_L_2019112209_N8527.kml", "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\MOSMIX_L_2019112209_N8527.txt"
'Kill "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\MOSMIX_L_2019112209_N8527.kml"
'Name "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\MOSMIX_L_2019112209_N8527.kml" As "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\MOSMIX_L_2019112209_N8527.txt"
'Name "C:\HSNR\ELMAR\Wärmenetz\Test Ordner\MOSMIX_L_2019111309_N8527.kml" As "C:\HSNR\ELMAR\Wärmenetz\Test Ordner\MOSMIX_L_2019111309_N8527.txt"
End Sub
Sub Importieren()
Workbooks.OpenText Filename:=NameZiel, _
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
End Sub
Public Function GetExcelfolder() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Bitte Ordner wählen"
.InitialFileName = "C:\"
.InitialView = msoFileDialogViewThumbnail
.ButtonName = "OK"
If .Show = -1 Then
GetExcelfolder = .SelectedItems(1)
End If
DownloadOrdner = GetExcelfolder & "\"
End With
End Function
Sub Sheetadd()
Windows(DateiExist).Activate
Sheets(DateiName).Select
Sheets(DateiName).Copy After:=Workbooks( _
"Berechnung_Wärmenetz(Beta_V6)xlsb.xlsm").Sheets(9)
Workbooks(DateiExist).Close SaveChanges:=False
End Sub
Sub Ordner()
ArchivOrdner = DownloadOrdner & "Archiv\"
If Dir(ArchivOrdner, vbDirectory) = "" Then
MkDir (ArchivOrdner)
Else
End If
End Sub
Hier ist mein gesamter Code, vielleicht liegt ja auch irgendwo anders das Problem.
Dim DateiName As String
Dim Zeit1 As Date
Dim Zeit2 As String
Dim Datum1 As Date
Dim Datum2 As String
Dim dieUrl As String
Dim DateiPfadzip As String
Dim myResult
Dim StationsID As String
Dim Zählen1 As Integer
Dim Zählen2 As Integer
Dim Zählen3 As Integer
Dim Zählen4 As Integer
Dim Zählen5 As Integer
Dim strFileName As String
Dim DateiExist As String
Dim DateiNameZip As String
Dim DateiNameTxt As String
Dim Name As String
Dim Test As String
Dim DownloadOrdner As String
Dim Pfad As String
Dim NameUrsprung As String
Dim NameZiel As String
Dim Laufdatei As String
Dim ArchivOrdner As String
Option Explicit
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
Sub Prognose()
Datum1 = Date 'aktuelles Datum wird in einer Datum Variable gespeichert
Datum2 = Format(Datum1, "YYYYMMDD" & "09") 'aktuelles Datum wird in einem String gespeichert
StationsID = Sheets("Rechner2").Cells(20, 4) 'Die StationsId wird in einer Variable gespeichert
Zeit1 = Format(Now, "h:mm

Zeit2 = Format(Zeit1, "hmmss") 'aktuele Uhrzeit wird in einem String gespeichert
Call GetExcelfolder
'DownloadOrdner = "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\"
Do
Zählen1 = Zählen1 + 1
Loop Until DownloadOrdner <> ""
Call Ordner
Call Download
Do
Zählen2 = Zählen2 + 1
DateiExist = Dir(DownloadOrdner)
DateiNameZip = DateiExist
Loop Until DateiExist <> ""
Name DownloadOrdner & DateiNameZip As ArchivOrdner & DateiNameZip
Do
Zählen3 = Zählen3 + 1
Loop Until Dir(ArchivOrdner & DateiExist) <> ""
Call Packen
Do
DateiExist = ""
DateiExist = Dir(DownloadOrdner)
DateiNameTxt = DateiExist
Zählen4 = Zählen4 + 1
Loop Until DateiExist <> ""
Call Umbenennen
DateiExist = ""
Do
Zählen5 = Zählen5 + 1
DateiExist = Dir(DownloadOrdner)
DateiNameTxt = DateiExist
Loop Until DateiExist = DateiName & ".txt"
Call Importieren
Call Sheetadd
Name DownloadOrdner & DateiNameTxt As ArchivOrdner & DateiName & Zeit2 & ".txt"
End
End Sub
Public Sub Download()
dieUrl = "https://opendata.dwd.de/weather/local_forecasts/mos/MOSMIX_L/single_stations/" & StationsID & "/kml/MOSMIX_L_LATEST_" & StationsID & ".kmz"
DateiPfadzip = DownloadOrdner & "\MOSMIX_L_LATEST_" & Datum2 & "_" & StationsID & "_" & Zeit2 & ".zip"
myResult = URLDownloadToFile(0, dieUrl, DateiPfadzip, 0, 0)
End Sub
Sub Packen()
Pfad = "C:\Programme\WinRAR\WinRAR.exe e " & ArchivOrdner & DateiExist & " " & DownloadOrdner
Shell (Pfad)
End Sub
Public Sub Umbenennen()
Do
NameUrsprung = DownloadOrdner & DateiExist
Loop Until NameUrsprung <> ""
DateiName = Left(DateiExist, Len(DateiExist) - 4)
Do
NameZiel = DownloadOrdner & DateiName & ".txt"
Loop Until NameZiel <> ""
FileCopy NameUrsprung, NameZiel
Kill NameUrsprung
'FileCopy "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\MOSMIX_L_2019112209_N8527.kml", "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\MOSMIX_L_2019112209_N8527.txt"
'Kill "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\MOSMIX_L_2019112209_N8527.kml"
'Name "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\MOSMIX_L_2019112209_N8527.kml" As "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\MOSMIX_L_2019112209_N8527.txt"
'Name "C:\HSNR\ELMAR\Wärmenetz\Test Ordner\MOSMIX_L_2019111309_N8527.kml" As "C:\HSNR\ELMAR\Wärmenetz\Test Ordner\MOSMIX_L_2019111309_N8527.txt"
End Sub
Sub Importieren()
Workbooks.OpenText Filename:=NameZiel, _
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
End Sub
Public Function GetExcelfolder() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Bitte Ordner wählen"
.InitialFileName = "C:\"
.InitialView = msoFileDialogViewThumbnail
.ButtonName = "OK"
If .Show = -1 Then
GetExcelfolder = .SelectedItems(1)
End If
DownloadOrdner = GetExcelfolder & "\"
End With
End Function
Sub Sheetadd()
Windows(DateiExist).Activate
Sheets(DateiName).Select
Sheets(DateiName).Copy After:=Workbooks( _
"Berechnung_Wärmenetz(Beta_V6)xlsb.xlsm").Sheets(9)
Workbooks(DateiExist).Close SaveChanges:=False
End Sub
Sub Ordner()
ArchivOrdner = DownloadOrdner & "Archiv\"
If Dir(ArchivOrdner, vbDirectory) = "" Then
MkDir (ArchivOrdner)
Else
End If
End Sub