Attribute VB_Name = "F_LottoZahlen"
Option Explicit

Function LottoZahlen(Optional ByVal Jahr As Integer = 0) As Variant

Const ColDate As Integer = 1
Const ColZahl As Integer = 2
Const CZahlen As Integer = 4
Const ColSupz As Integer = 8
Const OffQuot As Integer = 9
Const CSuperZ As Integer = 11
Const CQuoten As Integer = 13
Const MaxQZ   As Integer = 17

Dim AusJahr  As Integer
Dim FileID   As Integer
Dim GStufe   As Integer
Dim Loop1    As Integer
Dim Loop2    As Integer
Dim QZIndex  As Integer
Dim Zeile    As Integer

Dim RLoopD   As Long
Dim RLoopR   As Long

Dim HTTPObj  As Object

Dim LottoURL As String
Dim Member   As String
Dim URLError As String
Dim ZipData  As String

Dim Daten    As Variant
Dim GZ       As Variant
Dim Lines    As Variant
Dim LottoZuQ As Variant
Dim Repair   As Variant
Dim TempDir  As Variant
Dim TempName As Variant
Dim TempZip  As Variant

Dim URLData() As Byte

AusJahr = IIf(Jahr = 0, Year(Now), Jahr)
LottoURL = "https://www.lotto-hessen.de/static/gamebroker_5/de/download_files/" & _
           "lotto" & AusJahr & ".zip"
TempName = Environ("Temp") & "\Lotto." & Format(Now(), "dd.mm.yyyy.hhmmss")
TempDir = TempName & "\"
TempZip = TempName & ".zip"
Set HTTPObj = CreateObject("MSXML2.XMLHTTP")
Debug.Print LottoURL
HTTPObj.Open "GET", LottoURL, False
HTTPObj.Send
While Not HTTPObj.ReadyState = 4
      DoEvents
Wend
URLData = HTTPObj.ResponseBody
URLError = StrConv(URLData, vbUnicode)
If InStr(URLError, "404 Not Found<") > 0 Then
   ReDim LottoZuQ(0 To 0, 0 To 1)
   LottoZuQ(0, 1) = URLError
   GoTo FuncExit
End If
FileID = FreeFile
Open TempZip For Binary As #FileID
Put #FileID, , URLData
Close #FileID
Set HTTPObj = Nothing
URLData = vbNullString
MkDir TempDir
With CreateObject("Shell.Application")
    .Namespace(TempDir).CopyHere .Namespace(TempZip).items
End With
DoEvents
Member = Dir(TempDir & "*.txt")
ZipData = CreateObject("Scripting.FileSystemObject") _
             .OpenTextFile(TempDir & Member).ReadAll
Lines = Split(CreateObject("Scripting.FileSystemObject") _
             .OpenTextFile(TempDir & Member).ReadAll, vbLf)
Zeile = 0
ReDim LottoZuQ(1 To UBound(Lines), 1 To MaxQZ)
QZIndex = 0
For Loop1 = 1 To UBound(Lines)
    If Trim(Lines(Loop1)) = vbNullString Then GoTo Skip
    Daten = Split(Lines(Loop1), vbTab)
    If UBound(Daten) > 30 Then
       Repair = Daten
       Debug.Print Repair(0) & " " & Repair(1) & "." & Repair(2) & "." & Repair(3) & " Bounds = " & UBound(Daten)
       ReDim Daten(0 To 30)
       RLoopD = 1
       For RLoopR = 1 To UBound(Repair)
           If RLoopR > 3 And RLoopR < 16 Then
              If RLoopR Mod 2 = 0 Then GoTo SkipR
           End If
           Daten(RLoopD) = Repair(RLoopR)
           RLoopD = RLoopD + 1
SkipR:
       Next RLoopR
    End If
    QZIndex = QZIndex + 1
    LottoZuQ(QZIndex, ColDate) = CDate(Daten(1) & "." & Daten(2) & "." & Daten(3))
    ReDim GZ(1 To 6)
    For Loop2 = 1 To 6
        GZ(Loop2) = Right("0" & Daten(Loop2 + (CZahlen - 1)), 2)
    Next Loop2
    GZ = Application.Transpose(WorksheetFunction.Sort(Application.Transpose(GZ)))
    For Loop2 = 1 To 6
        LottoZuQ(QZIndex, ColZahl - 1 + Loop2) = GZ(Loop2) * 1 ' führende 0 entfernen
    Next Loop2
    LottoZuQ(QZIndex, ColSupz) = (Daten(CSuperZ)) ' * 1 ' Superzahl
    GStufe = 0
    If UBound(Daten) > CQuoten Then
       For Loop2 = CQuoten To UBound(Daten) Step 2
           If Not IsNumeric(Daten(Loop2 + 1)) Then
              LottoZuQ(QZIndex, OffQuot + GStufe) = vbNullString
           Else
             LottoZuQ(QZIndex, OffQuot + GStufe) = Replace(Daten(Loop2), ",", ".")
           End If
           GStufe = GStufe + 1
       Next Loop2
    End If
    Zeile = Zeile + 1
Skip:
Next Loop1

FuncExit:
Daten = vbNullString
Lines = vbNullString
With CreateObject("Scripting.FileSystemObject")
     On Error Resume Next
     .DeleteFile TempZip
     .DeleteFolder FolderSpec:=TempName, Force:=True ' ohne letzten \
     On Error GoTo 0
End With
LottoZahlen = LottoZuQ

End Function


Sub LottoJahr()

Dim Jahr As Integer
Dim Zahlen As Variant
Dim Blatt As String
Dim MaxRows As Long
Dim Loop1 As Long

Jahr = Year(Date)
Do
   Zahlen = LottoZahlen(Jahr)
   If UBound(Zahlen) = 0 Then Exit Do
   Blatt = "Lotto" & Jahr
   On Error Resume Next
   Sheets(Blatt).Select
   On Error GoTo 0
   If ActiveSheet.Name <> Blatt Then
      ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = Blatt
   End If
   Cells.Delete Shift:=xlUp
   Range(Cells(1, 2), Cells(UBound(Zahlen), UBound(Zahlen, 2))) = Zahlen
   Range(Columns(10), Columns(18)).NumberFormat = "#,##0.00 $"
   MaxRows = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
   For Loop1 = 1 To MaxRows
       Cells(Loop1, 1).Value = WeekdayName(Weekday(CDate(Cells(Loop1, 2).Value)), True, vbSunday)
   Next Loop1
   Cells.Columns.AutoFit
   Jahr = Jahr - 1
Loop
Debug.Print Zahlen(0, 1)

End Sub