Kalender (Schwer zu lösen)

[Frogger1986]

Warum muss es eigentlich eine Userform sein?
Ein Gantt- Diagramm wäre doch auch gut geeignet... 
Das lässt sich schnell übertragen und in allen erdenklichen Formen auswerten...

[Florian20]

Daran hab ich gar nicht gedacht.
Ich sehe es mir mal an danke für denn Tipp. :19:

[Florian20]

Also Ich habe mir das ganze nun angesehen.
Ich brauche aber eine UF da Ich Excel ausblende.

Die einfachste Version ist nun die einen Screenshot zu machen aber nur von dem Kalender.

[Fennek]

Hallo,

warum ein Screenshot helfen sollte, konnte ich nicht nachvollziehen.

Wenn du in meinem Code einige If-Abfragen ergänzt, kannst du für jedes Datum den Status auslesen. Mit einer Schleife über alle Appartments und alle Jahre ist eine vollständige Übertragung möglich.

mfg

[Florian20]

Ich habe mir dein Code nochmal angesehen und ja du hast recht.
Aber wie würdest Du das machen?

Gruß flo

[Fennek]

Hallo,

ich hatte mir das noch einmal angesehen:

eine "schöne" Lösung ist (für mich) recht kompliziert

Einfach, aber sehr effizient ist:

Code:

Sub F_en()
Dim HTP As Object

'ungeprüft
Url = "https://apartmani-laemmlein.com/bookingCalendar.php?apartment=1"

    With CreateObject("MSXML2.XMLHTTP")
        .Open "Get", Url, False
        .Send
        c00 = .ResponseText
    End With

    With CreateObject("htmlfile")
    
        .Body.innerhtml = c00
        Set Kn = .getElementsByTagName("span")
        For Each Zw In Kn
            'Debug.Print Zw.innertext, Zw.classname
        i=i+1
        cells(i,1) = Zw.innertext
        Next Zw

    End With
End Sub

Jedesmal wenn eine "1" kommt, beginnt ein neuer Monat. Dass Verschieben des Status sollte auch mit 1-2 Zeilen VBA (oder per Hand) gehen.

Die Schleife über die 3 Appartments ebenso. Es wird nur das aktuelle Jahr abgefragt, dafür habe ich i.M. keine Idee.

mfg

[Fennek]

versuche es mal so:

Code:

https://apartmani-laemmlein.com/bookingCalendar.php?apartment=1

Sub F_en()
Dim HTP As Object

Url = "https://apartmani-laemmlein.com/bookingCalendar.php?apartment=1"

    With CreateObject("MSXML2.XMLHTTP")
        .Open "Get", Url, False
        .Send
        c00 = .ResponseText
    End With

    With CreateObject("htmlfile")
    
        .Body.innerhtml = c00
        Set Kn = .getElementsByTagName("span")
        For Each Zw In Kn
            'Debug.Print Zw.innertext, Zw.classname
            If Zw.innertext <> "" Then
                it = Zw.innertext
            Else
                i = i + 1
                Cells(i, 1) = it
                Cells(i, 2) = Zw.classname
            End If
        Next Zw

    End With
End Sub

############# Version 2 ############
'Datei als UTF-8 speichern

Sub F_en()

Url = "https://apartmani-laemmlein.com/bookingCalendar.php?apartment=1"

    With CreateObject("MSXML2.XMLHTTP")
        .Open "Get", Url, False
        .Send
        c00 = .ResponseText
    End With

    With CreateObject("htmlfile")
    
        .Body.innerhtml = c00
        Set tr = .getElementsByTagName("tr")
        i = 1
        
        For Each Ast In tr
        Debug.Print Ast.innertext, VBA.MonthName(i)
            If VBA.MonthName(i) = Ast.innertext Then
                i = i + 1
                j = 1
                Cells(i, 1) = Ast.innertext
            End If
            Set Kn = Ast.getElementsByTagName("span")
            For Each Zw In Kn
                    If Zw.Classname <> "day" Then
                        j = j + 1
                        Cells(i, j) = Zw.Classname
                    End If
            Next Zw
        Next Ast
    End With
End Sub

[Florian20]

Hi guten morgen,

Wow krass also Ich hab mir den code angesehen ganz verstehen kann ich Ihn noch nicht, aber bei "Dezember kommt bei mir error.

Laufzeitfehler "5"
Ungültiger Prozeduraufruf oder Ungültiges Argument 

Wenn ich ein errorhandler einbaue dann bleibt der "Dezember" leer, ansonsten klapp das extrem gut.

Liebe Grüße Flo

PS: Der code hängt dann bei Ast.innertext in der debug.print anweisung wenn ich diese entferne hängt er in der if abfrage

[Florian20]

Hi Leute,

Ich hab das ganze nochmal durchdacht, und ich würde es gerne so machen wie im webbrowser Element.

Code:

Private Sub CommandButton1_Click()
   Dim strText As String, strArray() As String
   Dim lngRow As Long, lngCount As Long
   strText = WebBrowser1.Document.DocumentElement.outerTEXT
   strArray = Split(strText, vbCrLf)
   For lngCount = 0 To UBound(strArray)
       If Trim$(strArray(lngCount)) <> "" Then
           lngRow = lngRow + 1
           Cells(lngRow, 1).Value = Trim$(strArray(lngCount))
       End If
   Next
   Unload Me
End Sub

Private Sub UserForm_Activate()
   CommandButton1.Enabled = False
   WebBrowser1.Navigate "https://apartmani-laemmlein.com/bookingCalendar.php?apartment=1"
End Sub

Private Sub WebBrowser1_NavigateComplete2(ByVal pDisp As Object, URL As Variant)
   CommandButton1.Enabled = True
End Sub

Problem hier es wird nach unten angezeigt und die Buttons unterhalb des Kalenders werden angezeigt.
Zudem kann ich nicht nach Monaten schalten.

Frage:
Wäre es möglich mit dem Element das so zu machen wie Ich das brauche?

lg flo