10.12.2019, 17:49
Hallo Maninweb, Ich habe ein paar Dinge an dem Code verändert und hab natürlich jetzt wieder einen Fehler den ich selber nicht beheben kann bzw. mir ihn nicht erklren kann. Vielleicht kannst du mir wieder mal helfen.
Der Code sieht folgendermaßen aus, man muss dazu sagen, dass er noch nicht fertig ist. Die Zeile "strFileText = replace(strFileKML, ".kml", "_" & strTime & ".txt")" macht jetzt aber Probleme und sagt, dass ich einen Laufzeitfehler 13 habe und die Typen unverträglich sind.
Danke im Voraus!
Dim intZeileStart As Integer 'Beginn der Prognosetemperatur
Dim strBlattname As String
Dim Sheet As Worksheet
Dim find As Variant
Dim replace As Variant
Dim Kelvin As Double
Dim intSpalteStart As Integer
Dim intInhaltZelle As String
Dim intDatumPrognose As Integer
Dim DatumAktuell As Date
Dim strDate As String
Dim strTime As String
Dim lngError As Long
Dim lngResult As Long
Dim strArchive 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 strUrl As String
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 = "C:\"
' 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® < 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()
' Initialisieren...
lngError = 0
strDate = Format(Date, "YYYYMMDD")
strTime = Format(Time, "hhmmss")
strSeparator = Application.PathSeparator
strStation = ThisWorkbook.Worksheets("Rechner").Cells(4, 1).Value
' Prüfen...
If Len(strStation) < 1 Then
lngError = 1
Else
' Ordner abfragen...
If Sheets("Rechner").Cells(6, 1) = "" Then
strDownload = GetFolder(cstFolderDefault, False)
Sheets("Rechner").Cells(6, 1) = strDownload
Else
strDownload = Sheets("Rechner").Cells(6, 1)
End If
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", "_" & strTime & ".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)), DecimalSeparator:="." _
, ThousandsSeparator:=",", TrailingMinusNumbers:=True
' Kopieren...
'
' Ggf. ThisWorkbook durch Application.Workbooks("NAME") ersetzen
Application.Workbooks(Application.Workbooks.Count).Worksheets(1).Copy _
After:=ThisWorkbook.Worksheets(2)
' 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
Public Sub Ordnerwahl()
Sheets("Rechner").Cells(6, 1) = GetFolder(cstFolderDefault, False)
End Sub
Public Sub Prognosedaten()
Kelvin = 273.15
strDate = Format(Date, "YYYYMMDD")
strTime = Format(Time, "hhmmss")
SheetName = "Prog_" & strDate & "_" & strTime
'Suche nach "TTT"_________________________________________________________
Cells.find(What:="""TTT""", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
intZeileStart = ActiveCell.Row
intSpalteStart = ActiveCell.Column
'Cells.replace What:=".", Replacement:=",", LookAt:=xlPart, SearchOrder _
':=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
With ThisWorkbook
.Sheets.Add After:=Sheets(Worksheets.Count)
.ActiveSheet.Name = SheetName
End With
Sheets(SheetName).Cells(1, 1) = "Datum_Uhrzeit"
Sheets(SheetName).Cells(1, 2) = "Temp_i"
Sheets(SheetName).Cells(1, 3) = "Datum"
Sheets(SheetName).Cells(1, 4) = "Temp_d"
i = 0
Do
Sheets(SheetName).Cells(i + 2, 2) = Sheets(strBlattname).Cells(intZeileStart + 1, intSpalteStart + i) - Kelvin
i = i + 1
Loop Until IsNumeric(Sheets(strBlattname).Cells(intZeileStart + 1, intSpalteStart + i)) = False
'Suche nach timestep
Worksheets(strBlattname).Select
Cells.find(What:="timestep", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
Cells.FindNext(After:=ActiveCell).Activate
intInhaltZelle = ActiveCell
strDatumPrognose = GetNumeric(intInhaltZelle)
testDate = CDate(strDatumPrognose)
Sheets(SheetName).Cells(2, 1) = testDate
For j = 0 To i - 2
Sheets(SheetName).Cells(j + 3, 1) = Sheets(SheetName).Cells(j + 2, 1) + 1 / 24
Next j
Worksheets(SheetName).Select
Columns("A:A").Select
Selection.NumberFormat = "m/d/yyyy h:mm"
i = 1
Laufvariable1 = 0
Worksheets(SheetName).Activate
Zeile1 = 2
Do Until Range("B1").Offset(i, 0) = ""
TagZahl = TagZahl + 1
Laufvariable1 = Laufvariable1 + 1
If Laufvariable1 = 1 Then
Laufvariable2 = Sheets(SheetName).Cells(i + 1, 2)
Else
Laufvariable2 = Laufvariable2 + Sheets(SheetName).Cells(i + 1, 2)
End If
If Laufvariable1 = 24 Then
Sheets(SheetName).Cells(Zeile1, 4) = Laufvariable2 / 24
Zeile1 = Zeile1 + 1
Laufvariable1 = 0
End If
i = i + 1
Loop
TagZahl = (TagZahl / 24)
End Sub
Der Code sieht folgendermaßen aus, man muss dazu sagen, dass er noch nicht fertig ist. Die Zeile "strFileText = replace(strFileKML, ".kml", "_" & strTime & ".txt")" macht jetzt aber Probleme und sagt, dass ich einen Laufzeitfehler 13 habe und die Typen unverträglich sind.
Danke im Voraus!
Dim intZeileStart As Integer 'Beginn der Prognosetemperatur
Dim strBlattname As String
Dim Sheet As Worksheet
Dim find As Variant
Dim replace As Variant
Dim Kelvin As Double
Dim intSpalteStart As Integer
Dim intInhaltZelle As String
Dim intDatumPrognose As Integer
Dim DatumAktuell As Date
Dim strDate As String
Dim strTime As String
Dim lngError As Long
Dim lngResult As Long
Dim strArchive 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 strUrl As String
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 = "C:\"
' 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® < 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()
' Initialisieren...
lngError = 0
strDate = Format(Date, "YYYYMMDD")
strTime = Format(Time, "hhmmss")
strSeparator = Application.PathSeparator
strStation = ThisWorkbook.Worksheets("Rechner").Cells(4, 1).Value
' Prüfen...
If Len(strStation) < 1 Then
lngError = 1
Else
' Ordner abfragen...
If Sheets("Rechner").Cells(6, 1) = "" Then
strDownload = GetFolder(cstFolderDefault, False)
Sheets("Rechner").Cells(6, 1) = strDownload
Else
strDownload = Sheets("Rechner").Cells(6, 1)
End If
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", "_" & strTime & ".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)), DecimalSeparator:="." _
, ThousandsSeparator:=",", TrailingMinusNumbers:=True
' Kopieren...
'
' Ggf. ThisWorkbook durch Application.Workbooks("NAME") ersetzen
Application.Workbooks(Application.Workbooks.Count).Worksheets(1).Copy _
After:=ThisWorkbook.Worksheets(2)
' 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
Public Sub Ordnerwahl()
Sheets("Rechner").Cells(6, 1) = GetFolder(cstFolderDefault, False)
End Sub
Public Sub Prognosedaten()
Kelvin = 273.15
strDate = Format(Date, "YYYYMMDD")
strTime = Format(Time, "hhmmss")
SheetName = "Prog_" & strDate & "_" & strTime
'Suche nach "TTT"_________________________________________________________
Cells.find(What:="""TTT""", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
intZeileStart = ActiveCell.Row
intSpalteStart = ActiveCell.Column
'Cells.replace What:=".", Replacement:=",", LookAt:=xlPart, SearchOrder _
':=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
With ThisWorkbook
.Sheets.Add After:=Sheets(Worksheets.Count)
.ActiveSheet.Name = SheetName
End With
Sheets(SheetName).Cells(1, 1) = "Datum_Uhrzeit"
Sheets(SheetName).Cells(1, 2) = "Temp_i"
Sheets(SheetName).Cells(1, 3) = "Datum"
Sheets(SheetName).Cells(1, 4) = "Temp_d"
i = 0
Do
Sheets(SheetName).Cells(i + 2, 2) = Sheets(strBlattname).Cells(intZeileStart + 1, intSpalteStart + i) - Kelvin
i = i + 1
Loop Until IsNumeric(Sheets(strBlattname).Cells(intZeileStart + 1, intSpalteStart + i)) = False
'Suche nach timestep
Worksheets(strBlattname).Select
Cells.find(What:="timestep", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
Cells.FindNext(After:=ActiveCell).Activate
intInhaltZelle = ActiveCell
strDatumPrognose = GetNumeric(intInhaltZelle)
testDate = CDate(strDatumPrognose)
Sheets(SheetName).Cells(2, 1) = testDate
For j = 0 To i - 2
Sheets(SheetName).Cells(j + 3, 1) = Sheets(SheetName).Cells(j + 2, 1) + 1 / 24
Next j
Worksheets(SheetName).Select
Columns("A:A").Select
Selection.NumberFormat = "m/d/yyyy h:mm"
i = 1
Laufvariable1 = 0
Worksheets(SheetName).Activate
Zeile1 = 2
Do Until Range("B1").Offset(i, 0) = ""
TagZahl = TagZahl + 1
Laufvariable1 = Laufvariable1 + 1
If Laufvariable1 = 1 Then
Laufvariable2 = Sheets(SheetName).Cells(i + 1, 2)
Else
Laufvariable2 = Laufvariable2 + Sheets(SheetName).Cells(i + 1, 2)
End If
If Laufvariable1 = 24 Then
Sheets(SheetName).Cells(Zeile1, 4) = Laufvariable2 / 24
Zeile1 = Zeile1 + 1
Laufvariable1 = 0
End If
i = i + 1
Loop
TagZahl = (TagZahl / 24)
End Sub
