Zuviel Werbung? - > Hier kostenlos beim SPS-Forum registrieren

Seite 1 von 2 12 LetzteLetzte
Ergebnis 1 bis 10 von 14

Thema: vbs in Wicc Tia V13 verwenden

  1. #1
    Registriert seit
    10.08.2010
    Beiträge
    770
    Danke
    1
    Erhielt 14 Danke für 13 Beiträge

    Standard


    Zuviel Werbung?
    -> Hier kostenlos registrieren
    Hallo
    ich habe ein vbs Script mit dem ich mir am PC den Leistungswert eine Fritz DECT 200 Steckdose anzeigen lassen kann.
    gibt es eine Möglichkeit diese Script in Wicc V13 zu verwenden ?
    ICh würde gerne die Variable in die SPS schreiben
    Code:
    '---- Fritz!DECT200-Einschalten-VBS 
    
    On Error Resume Next
    
    ' ----------------- IM FOLGENDEN ABGEGRENZTEN ABSCHNITT MÜSSEN EINIGE SPEZIFISCHE ANGABEN GEMACHT WERDEN ------------------
    
    AIN = "084610121357"    ' Aktor-Identifikations-Nummer (WICHTIG: Ohne Leerzeichen eingeben!!!)
    host = "fritz.box"      ' Fritzbox Adresse im Netzwerk ggf. auch die direkte IP-Adresse
    pass = "Passwort"       ' Passwort zum Einloggen in die Benutzeroberfläche der Fritzbox andernfalls erscheint eine Inputbox
    user = "User"            ' Beim Einloggen in die Fritzbox per Username UND Passwort bitte hier noch den Usernamen angeben, andernfalls auf "False" lassen!
    
    ' -------------------------------------------------------------------------------------------------------------------------
    
    If pass = "" Then pass = InputBox("Bitte Passwort eingeben!")
    
    Private Const BITS_TO_A_BYTE=8
    Private Const BYTES_TO_A_WORD=4
    Private Const BITS_TO_A_WORD=32
    Private m_lOnBits(30)
    Private m_l2Power(30)
    m_lOnBits(0)=CLng(1)
    m_lOnBits(1)=CLng(3)
    m_lOnBits(2)=CLng(7)
    m_lOnBits(3)=CLng(15)
    m_lOnBits(4)=CLng(31)
    m_lOnBits(5)=CLng(63)
    m_lOnBits(6)=CLng(127)
    m_lOnBits(7)=CLng(255)
    m_lOnBits(8)=CLng(511)
    m_lOnBits(9)=CLng(1023)
    m_lOnBits(10)=CLng(2047)
    m_lOnBits(11)=CLng(4095)
    m_lOnBits(12)=CLng(8191)
    m_lOnBits(13)=CLng(16383)
    m_lOnBits(14)=CLng(32767)
    m_lOnBits(15)=CLng(65535)
    m_lOnBits(16)=CLng(131071)
    m_lOnBits(17)=CLng(262143)
    m_lOnBits(18)=CLng(524287)
    m_lOnBits(19)=CLng(1048575)
    m_lOnBits(20)=CLng(2097151)
    m_lOnBits(21)=CLng(4194303)
    m_lOnBits(22)=CLng(8388607)
    m_lOnBits(23)=CLng(16777215)
    m_lOnBits(24)=CLng(33554431)
    m_lOnBits(25)=CLng(67108863)
    m_lOnBits(26)=CLng(134217727)
    m_lOnBits(27)=CLng(268435455)
    m_lOnBits(28)=CLng(536870911)
    m_lOnBits(29)=CLng(1073741823)
    m_lOnBits(30)=CLng(2147483647)
    m_l2Power(0)=CLng(1)
    m_l2Power(1)=CLng(2)
    m_l2Power(2)=CLng(4)
    m_l2Power(3)=CLng(8)
    m_l2Power(4)=CLng(16)
    m_l2Power(5)=CLng(32)
    m_l2Power(6)=CLng(64)
    m_l2Power(7)=CLng(128)
    m_l2Power(8)=CLng(256)
    m_l2Power(9)=CLng(512)
    m_l2Power(10)=CLng(1024)
    m_l2Power(11)=CLng(2048)
    m_l2Power(12)=CLng(4096)
    m_l2Power(13)=CLng(8192)
    m_l2Power(14)=CLng(16384)
    m_l2Power(15)=CLng(32768)
    m_l2Power(16)=CLng(65536)
    m_l2Power(17)=CLng(131072)
    m_l2Power(18)=CLng(262144)
    m_l2Power(19)=CLng(524288)
    m_l2Power(20)=CLng(1048576)
    m_l2Power(21)=CLng(2097152)
    m_l2Power(22)=CLng(4194304)
    m_l2Power(23)=CLng(8388608)
    m_l2Power(24)=CLng(16777216)
    m_l2Power(25)=CLng(33554432)
    m_l2Power(26)=CLng(67108864)
    m_l2Power(27)=CLng(134217728)
    m_l2Power(28)=CLng(268435456)
    m_l2Power(29)=CLng(536870912)
    m_l2Power(30)=CLng(1073741824)
    Private Function LShift(lValue,iShiftBits)
     If iShiftBits=0 Then
      LShift=lValue
      Exit Function
     ElseIf iShiftBits=31 Then
      If lValue And 1 Then
       LShift=&H80000000
      Else
       LShift=0
      End If
      Exit Function
     ElseIf iShiftBits<0 Or iShiftBits>31 Then
      Err.Raise 6
     End If
     If(lValue And m_l2Power(31-iShiftBits))Then
      LShift=((lValue And m_lOnBits(31-(iShiftBits+1)))*m_l2Power(iShiftBits))Or &H80000000
     Else
      LShift=((lValue And m_lOnBits(31-iShiftBits))*m_l2Power(iShiftBits))
     End If
    End Function
    Private Function RShift(lValue,iShiftBits)
     If iShiftBits=0 Then
      RShift=lValue
      Exit Function
     ElseIf iShiftBits=31 Then
      If lValue And &H80000000 Then
       RShift=1
      Else
       RShift=0
      End If
      Exit Function
     ElseIf iShiftBits<0 Or iShiftBits>31 Then
      Err.Raise 6
     End If
     RShift=(lValue And &H7FFFFFFE)\m_l2Power(iShiftBits)
     If(lValue And &H80000000)Then
      RShift=(RShift Or(&H40000000\m_l2Power(iShiftBits-1)))
     End If
    End Function
    Private Function RotateLeft(lValue,iShiftBits)
     RotateLeft=LShift(lValue,iShiftBits)Or RShift(lValue,(32-iShiftBits))
    End Function
    Private Function AddUnsigned(lX,lY)
     Dim lX4
     Dim lY4
     Dim lX8
     Dim lY8
     Dim lResult
     lX8=lX And &H80000000
     lY8=lY And &H80000000
     lX4=lX And &H40000000
     lY4=lY And &H40000000
     lResult=(lX And &H3FFFFFFF)+(lY And &H3FFFFFFF)
     If lX4 And lY4 Then
      lResult=lResult Xor &H80000000 Xor lX8 Xor lY8
     ElseIf lX4 Or lY4 Then
      If lResult And &H40000000 Then
       lResult=lResult Xor &HC0000000 Xor lX8 Xor lY8
      Else
       lResult=lResult Xor &H40000000 Xor lX8 Xor lY8
      End If
     Else
      lResult=lResult Xor lX8 Xor lY8
     End If
     AddUnsigned=lResult
    End Function
    Private Function F(x,y,z)
     F=(x And y)Or((Not x)And z)
    End Function
    Private Function G(x,y,z)
     G=(x And z)Or(y And(Not z))
    End Function
    Private Function H(x,y,z)
     H=(x Xor y Xor z)
    End Function
    Private Function I(x,y,z)
     I=(y Xor(x Or(Not z)))
    End Function
    Private Sub FF(a,b,c,d,x,s,ac)
     a=AddUnsigned(a,AddUnsigned(AddUnsigned(F(b,c,d),x),ac))
     a=RotateLeft(a,s)
     a=AddUnsigned(a,b)
    End Sub
    Private Sub GG(a,b,c,d,x,s,ac)
     a=AddUnsigned(a,AddUnsigned(AddUnsigned(G(b,c,d),x),ac))
     a=RotateLeft(a,s)
     a=AddUnsigned(a,b)
    End Sub
    Private Sub HH(a,b,c,d,x,s,ac)
     a=AddUnsigned(a,AddUnsigned(AddUnsigned(H(b,c,d),x),ac))
     a=RotateLeft(a,s)
     a=AddUnsigned(a,b)
    End Sub
    Private Sub II(a,b,c,d,x,s,ac)
     a=AddUnsigned(a,AddUnsigned(AddUnsigned(I(b,c,d),x),ac))
     a=RotateLeft(a,s)
     a=AddUnsigned(a,b)
    End Sub
    Private Function ConvertToWordArray(sMessage)
     Dim lMessageLength
     Dim lNumberOfWords
     Dim lWordArray()
     Dim lBytePosition
     Dim lByteCount
     Dim lWordCount
     Const MODULUS_BITS=512
     Const CONGRUENT_BITS=448
     lMessageLength=Len(sMessage)
     lNumberOfWords=(((lMessageLength+((MODULUS_BITS-CONGRUENT_BITS)\BITS_TO_A_BYTE))\(MODULUS_BITS\BITS_TO_A_BYTE))+1)*(MODULUS_BITS\BITS_TO_A_WORD)
     ReDim lWordArray(lNumberOfWords-1)
     lBytePosition=0
     lByteCount=0
     Do Until lByteCount>=lMessageLength
      lWordCount=lByteCount\BYTES_TO_A_WORD
      lBytePosition=(lByteCount Mod BYTES_TO_A_WORD)*BITS_TO_A_BYTE
      lWordArray(lWordCount)=lWordArray(lWordCount)Or LShift(Asc(Mid(sMessage,lByteCount+1,1)),lBytePosition)
      lByteCount=lByteCount+1
     Loop
     lWordCount=lByteCount\BYTES_TO_A_WORD
     lBytePosition=(lByteCount Mod BYTES_TO_A_WORD)*BITS_TO_A_BYTE
     lWordArray(lWordCount)=lWordArray(lWordCount)Or LShift(&H80,lBytePosition)
     lWordArray(lNumberOfWords-2)=LShift(lMessageLength,3)
     lWordArray(lNumberOfWords-1)=RShift(lMessageLength,29)
     ConvertToWordArray=lWordArray
    End Function
    Private Function WordToHex(lValue)
     Dim lByte
     Dim lCount
     For lCount=0 To 3
      lByte=RShift(lValue,lCount*BITS_TO_A_BYTE)And m_lOnBits(BITS_TO_A_BYTE-1)
      WordToHex=WordToHex & Right("0" & Hex(lByte),2)
     Next
    End Function
    Public Function MD5(sMessage)
     Dim x
     Dim k
     Dim AA
     Dim BB
     Dim CC
     Dim DD
     Dim a
     Dim b
     Dim c
     Dim d
     Const S11=7
     Const S12=12
     Const S13=17
     Const S14=22
     Const S21=5
     Const S22=9
     Const S23=14
     Const S24=20
     Const S31=4
     Const S32=11
     Const S33=16
     Const S34=23
     Const S41=6
     Const S42=10
     Const S43=15
     Const S44=21
     x=ConvertToWordArray(sMessage)
     a=&H67452301
     b=&HEFCDAB89
     c=&H98BADCFE
     d=&H10325476
     For k=0 To UBound(x)Step 16
      AA=a
      BB=b
      CC=c
      DD=d
      FF a,b,c,d,x(k+0),S11,&HD76AA478
      FF d,a,b,c,x(k+1),S12,&HE8C7B756
      FF c,d,a,b,x(k+2),S13,&H242070DB
      FF b,c,d,a,x(k+3),S14,&HC1BDCEEE
      FF a,b,c,d,x(k+4),S11,&HF57C0FAF
      FF d,a,b,c,x(k+5),S12,&H4787C62A
      FF c,d,a,b,x(k+6),S13,&HA8304613
      FF b,c,d,a,x(k+7),S14,&HFD469501
      FF a,b,c,d,x(k+8),S11,&H698098D8
      FF d,a,b,c,x(k+9),S12,&H8B44F7AF
      FF c,d,a,b,x(k+10),S13,&HFFFF5BB1
      FF b,c,d,a,x(k+11),S14,&H895CD7BE
      FF a,b,c,d,x(k+12),S11,&H6B901122
      FF d,a,b,c,x(k+13),S12,&HFD987193
      FF c,d,a,b,x(k+14),S13,&HA679438E
      FF b,c,d,a,x(k+15),S14,&H49B40821
      GG a,b,c,d,x(k+1),S21,&HF61E2562
      GG d,a,b,c,x(k+6),S22,&HC040B340
      GG c,d,a,b,x(k+11),S23,&H265E5A51
      GG b,c,d,a,x(k+0),S24,&HE9B6C7AA
      GG a,b,c,d,x(k+5),S21,&HD62F105D
      GG d,a,b,c,x(k+10),S22,&H2441453
      GG c,d,a,b,x(k+15),S23,&HD8A1E681
      GG b,c,d,a,x(k+4),S24,&HE7D3FBC8
      GG a,b,c,d,x(k+9),S21,&H21E1CDE6
      GG d,a,b,c,x(k+14),S22,&HC33707D6
      GG c,d,a,b,x(k+3),S23,&HF4D50D87
      GG b,c,d,a,x(k+8),S24,&H455A14ED
      GG a,b,c,d,x(k+13),S21,&HA9E3E905
      GG d,a,b,c,x(k+2),S22,&HFCEFA3F8
      GG c,d,a,b,x(k+7),S23,&H676F02D9
      GG b,c,d,a,x(k+12),S24,&H8D2A4C8A
      HH a,b,c,d,x(k+5),S31,&HFFFA3942
      HH d,a,b,c,x(k+8),S32,&H8771F681
      HH c,d,a,b,x(k+11),S33,&H6D9D6122
      HH b,c,d,a,x(k+14),S34,&HFDE5380C
      HH a,b,c,d,x(k+1),S31,&HA4BEEA44
      HH d,a,b,c,x(k+4),S32,&H4BDECFA9
      HH c,d,a,b,x(k+7),S33,&HF6BB4B60
      HH b,c,d,a,x(k+10),S34,&HBEBFBC70
      HH a,b,c,d,x(k+13),S31,&H289B7EC6
      HH d,a,b,c,x(k+0),S32,&HEAA127FA
      HH c,d,a,b,x(k+3),S33,&HD4EF3085
      HH b,c,d,a,x(k+6),S34,&H4881D05
      HH a,b,c,d,x(k+9),S31,&HD9D4D039
      HH d,a,b,c,x(k+12),S32,&HE6DB99E5
      HH c,d,a,b,x(k+15),S33,&H1FA27CF8
      HH b,c,d,a,x(k+2),S34,&HC4AC5665
      II a,b,c,d,x(k+0),S41,&HF4292244
      II d,a,b,c,x(k+7),S42,&H432AFF97
      II c,d,a,b,x(k+14),S43,&HAB9423A7
      II b,c,d,a,x(k+5),S44,&HFC93A039
      II a,b,c,d,x(k+12),S41,&H655B59C3
      II d,a,b,c,x(k+3),S42,&H8F0CCC92
      II c,d,a,b,x(k+10),S43,&HFFEFF47D
      II b,c,d,a,x(k+1),S44,&H85845DD1
      II a,b,c,d,x(k+8),S41,&H6FA87E4F
      II d,a,b,c,x(k+15),S42,&HFE2CE6E0
      II c,d,a,b,x(k+6),S43,&HA3014314
      II b,c,d,a,x(k+13),S44,&H4E0811A1
      II a,b,c,d,x(k+4),S41,&HF7537E82
      II d,a,b,c,x(k+11),S42,&HBD3AF235
      II c,d,a,b,x(k+2),S43,&H2AD7D2BB
      II b,c,d,a,x(k+9),S44,&HEB86D391
      a=AddUnsigned(a,AA)
      b=AddUnsigned(b,BB)
      c=AddUnsigned(c,CC)
      d=AddUnsigned(d,DD)
     Next
     MD5=LCase(WordToHex(a)&WordToHex(b)&WordToHex(c)&WordToHex(d))
    End Function
    Public Function SendPost(http,page,host,post)
     With http
      .Open "POST", "http://" & host & page,false
      .setRequestHeader "HOST", host
      .setRequestHeader "Connection", "Keep-Alive"
      .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
      .setRequestHeader "Content-Length", Len(post)
      .Send post
     End With
     SendPost = http.responseText
    End Function
    Public Function Response(xml,pass)
     Set re = new regexp
     re.Pattern = "<Challenge>(\w+)</Challenge>"
     Set match = re.Execute(xml)
     If(match.count > 0) Then
      auth = match(0).SubMatches(0)
      code = ""
      xml = auth & "-" & pass
      For a = 1 To Len(xml)
       code = code & Mid(xml,a,1) & chr(0)
      Next
      Response = "response=" & auth & "-" & md5(code)
     End If
    End Function
    Public Function GetSid(xml)
     Set re = new regexp
     re.Pattern = "<SID>(?!0{16})(\w+)</SID>"
     Set match = re.Execute(xml)
     If(match.count > 0) Then
      GetSid = "sid=" & match(0).SubMatches(0)
     End If
    End Function
    
    Set http = Nothing
    Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
    If http Is Nothing Then Set http = CreateObject("WinHttp.WinHttpRequest.5")
    If http Is Nothing Then Set http = CreateObject("WinHttp.WinHttpRequest")
    If http Is Nothing Then Set http = CreateObject("MSXML2.ServerXMLHTTP")
    If http Is Nothing Then Set http = CreateObject("Microsoft.XMLHTTP")
    If http Is Nothing Then
     MsgBox "Kein HTTP-Objekt verfügbar!",16,"Fehlermeldung"
    Else
     sid = ""
     page = "/login_sid.lua"
     http.Open "GET", "http://" & host & page,false
     http.Send
     auth = Response(http.responseText,pass)
     If auth <> "" Then
      If auth Then
       If user Then
        auth = auth & "&username=" & user
       End If
       sid = GetSid(SendPost(http,page,host,auth))    ' Einloggen (lua)
      Else
      End If
      If sid = "" Then
       page = "/cgi-bin/webcm"
       data = "getpage=../html/login_sid.xml"
       http.Open "GET", "http://" & host & page & "?" & data,false
       http.Send
       auth = Response(http.responseText,pass)
       If auth Then
        sid = GetSid(SendPost(http,page,host,data & "&login:command/" & auth))    ' Einloggen (cgi)
       Else
        data = SendPost(http,page,host,"login:command/password=" & pass)
       End If
      End If
      If sid <> "" Then
       url = "http://" & host & "//webservices/homeautoswitch.lua?" & sid & "&ain=" & AIN & "&switchcmd=getswitchpower"
       http.Open "GET",url,False
       http.Send  
       Energieaktuell = http.responseText
       Energieaktuell=Energieaktuell/1000
      Else
       MsgBox "Passwort oder Benutzername möglicherweise falsch! ",vbOKOnly,"Fehlermeldung"
      End If
      MsgBox "Leistung "& Energieaktuell & " Watt"
      
      If sid <> "" Then                            ' Ausloggen
       text = SendPost(http,page,host,"security:command/logout=1" & sid)
      End If
     Else
      MsgBox "Kann die Fritzbox über die Adresse '" & host & "' nicht erreichen! ",vbOKOnly,"Fehlermeldung" 
     End If
    End If
    Zitieren Zitieren vbs in Wicc Tia V13 verwenden  

  2. #2
    Registriert seit
    20.06.2003
    Ort
    Sauerland.NRW.Deutschland
    Beiträge
    4.850
    Danke
    78
    Erhielt 800 Danke für 543 Beiträge

    Standard

    ohne das ich mir das script jetzt genau angesehen habe.
    wohin erfolgt die ausgabe? in einer msgbox?

    dann einfach das script als externes programm aus der hmi starten und die ausgabe in eine datei schreiben.
    diese datei dann mit der hmi einlesen.
    evtl könnte man das script auf für die hmi anpassen wäre aber aufwendiger.
    .
    mfg Volker .......... .. alles wird gut ..

    =>Meine Homepage .. direkt zum Download

    Meine Definition von TIA: Total Inakzeptable Applikation

  3. #3
    Registriert seit
    10.08.2010
    Beiträge
    770
    Danke
    1
    Erhielt 14 Danke für 13 Beiträge

    Standard

    Hallo
    die Ausgabe erfolt im Script in einer msgbox. Dies war aber nur für Test zwecke gedacht.
    Wie bekomme ich die Ausgabe in eine Wicc flexible Variabel wenn ich das Script als externes Programm ausführe ?

  4. #4
    Registriert seit
    17.04.2008
    Ort
    Oberfranken
    Beiträge
    61
    Danke
    3
    Erhielt 80 Danke für 16 Beiträge

    Standard

    Hallo

    schreib doch das Ergebnis in ein Textfile.
    Das (den Inhalt) kannst du dann mit einem Script in TIA einlesen und auswerten.

    Gruß
    Aweeller

  5. #5
    Registriert seit
    10.08.2010
    Beiträge
    770
    Danke
    1
    Erhielt 14 Danke für 13 Beiträge

    Standard

    Hallo
    fals ein Erfahrener VB Experte mir helfen möchte den Code in Wicc Tia Script mit einzubinde wäre ich sehr dankbar. Damit wäre es dann Möglich fritzbox befehle zu senden und zu empfangen.

    z.B
    Wlan An , Wlan Aus, DECT 200 Schalen, Anrufe be Ereignissen usw.

  6. #6
    Registriert seit
    20.06.2003
    Ort
    Sauerland.NRW.Deutschland
    Beiträge
    4.850
    Danke
    78
    Erhielt 800 Danke für 543 Beiträge

    Standard

    Zitat Zitat von emilio20 Beitrag anzeigen
    Hallo
    die Ausgabe erfolt im Script in einer msgbox. Dies war aber nur für Test zwecke gedacht.
    Wie bekomme ich die Ausgabe in eine Wicc flexible Variabel wenn ich das Script als externes Programm ausführe ?
    in deinem script gibt es nur eine relevante ausgabe in zeile 402

    Code:
    ergänze in deinem script
    ganz oben einfügen
    
    dim ausgabe, ausgabedatei
    ausgabedatei = "c:\fritzausgabe.txt" 'oder was auch immer
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ausgabe = fso.createTextFile(ausgabedatei, 1)
    
    grundsätzlich ersetzte msgbox durch ausgabe.writeline
    -->
    aus zeile 402 MsgBox "Leistung "& Energieaktuell & " Watt"
    wird
    ausgabe.writeline Energieaktuell
    
    am ande vom script einfügen
    ausgabe.close
    aufruf des externen scripts über die funktion 'Starte Programm'

    Code:
    die erzeugte datei im hmi einlesen.
    
    dim eingabe,eingabedatei
    eingabedatei = "c:\fritzausgabe.txt" 'oder was auch immer
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set eingabe = fs.openTextFile(eingabedatei, 1)
    SmartTags("eingelesener_wert") = eingabe.readline
    eingabe.close
    das solltest du dir anschauen.
    http://www.sps-forum.de/faq/15348-pr...vb-script.html
    .
    mfg Volker .......... .. alles wird gut ..

    =>Meine Homepage .. direkt zum Download

    Meine Definition von TIA: Total Inakzeptable Applikation

  7. #7
    Registriert seit
    10.08.2010
    Beiträge
    770
    Danke
    1
    Erhielt 14 Danke für 13 Beiträge

    Standard

    Hallo
    super vielen Dank werde es heute mal Teste.
    Kannst du mir eine gute VB Script legtüre empfehlern für Wincc flex oder V13.
    Ich kenne mich in VB nicht gut aus.

    Könnstest du kurz beschreiben was du in deinem Script genau machst ?

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ausgabe = fso.createTextFile(ausgabedatei, 1)
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set eingabe = fs.openTextFile(eingabedatei, 1)
    SmartTags("eingelesener_wert") = eingabe.readline

  8. #8
    Registriert seit
    10.08.2010
    Beiträge
    770
    Danke
    1
    Erhielt 14 Danke für 13 Beiträge

    Standard

    Hallo
    ich habe den Code mal so geängert. Es wird aber keine tex Datei angelegt.
    Wenn ich den oberen Teil vor "On Error Resume Next" setze erhalte ich einen Fehler.



    Code:
    '---- Fritz!DECT200-Einschalten-VBS by Eddy - Thanks to Michael Engelke <http://www.mengelke.de> for his logindemo.vbs ----
    
    On Error Resume Next
    
    dim ausgabe, ausgabedatei
    ausgabedatei = "c:\FRITZ\fritzausgabe.txt" 'oder was auch immer
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ausgabe = fso.createTextFile(ausgabedatei, 1)
    
    
    ' ----------------- IM FOLGENDEN ABGEGRENZTEN ABSCHNITT MÜSSEN EINIGE SPEZIFISCHE ANGABEN GEMACHT WERDEN ------------------
    
    AIN = "087210162457"    ' Aktor-Identifikations-Nummer (WICHTIG: Ohne Leerzeichen eingeben!!!)
    host = "fritz.box"      ' Fritzbox Adresse im Netzwerk ggf. auch die direkte IP-Adresse
    pass = "**********"       ' Passwort zum Einloggen in die Benutzeroberfläche der Fritzbox andernfalls erscheint eine Inputbox
    user = "Andreas"            ' Beim Einloggen in die Fritzbox per Username UND Passwort bitte hier noch den Usernamen angeben, andernfalls auf "False" lassen!
    
    
    ' -------------------------------------------------------------------------------------------------------------------------
    
    If pass = "" Then pass = InputBox("Bitte Passwort eingeben!")
    
    Private Const BITS_TO_A_BYTE=8
    Private Const BYTES_TO_A_WORD=4
    Private Const BITS_TO_A_WORD=32
    Private m_lOnBits(30)
    Private m_l2Power(30)
    m_lOnBits(0)=CLng(1)
    m_lOnBits(1)=CLng(3)
    m_lOnBits(2)=CLng(7)
    m_lOnBits(3)=CLng(15)
    m_lOnBits(4)=CLng(31)
    m_lOnBits(5)=CLng(63)
    m_lOnBits(6)=CLng(127)
    m_lOnBits(7)=CLng(255)
    m_lOnBits(8)=CLng(511)
    m_lOnBits(9)=CLng(1023)
    m_lOnBits(10)=CLng(2047)
    m_lOnBits(11)=CLng(4095)
    m_lOnBits(12)=CLng(8191)
    m_lOnBits(13)=CLng(16383)
    m_lOnBits(14)=CLng(32767)
    m_lOnBits(15)=CLng(65535)
    m_lOnBits(16)=CLng(131071)
    m_lOnBits(17)=CLng(262143)
    m_lOnBits(18)=CLng(524287)
    m_lOnBits(19)=CLng(1048575)
    m_lOnBits(20)=CLng(2097151)
    m_lOnBits(21)=CLng(4194303)
    m_lOnBits(22)=CLng(8388607)
    m_lOnBits(23)=CLng(16777215)
    m_lOnBits(24)=CLng(33554431)
    m_lOnBits(25)=CLng(67108863)
    m_lOnBits(26)=CLng(134217727)
    m_lOnBits(27)=CLng(268435455)
    m_lOnBits(28)=CLng(536870911)
    m_lOnBits(29)=CLng(1073741823)
    m_lOnBits(30)=CLng(2147483647)
    m_l2Power(0)=CLng(1)
    m_l2Power(1)=CLng(2)
    m_l2Power(2)=CLng(4)
    m_l2Power(3)=CLng(8)
    m_l2Power(4)=CLng(16)
    m_l2Power(5)=CLng(32)
    m_l2Power(6)=CLng(64)
    m_l2Power(7)=CLng(128)
    m_l2Power(8)=CLng(256)
    m_l2Power(9)=CLng(512)
    m_l2Power(10)=CLng(1024)
    m_l2Power(11)=CLng(2048)
    m_l2Power(12)=CLng(4096)
    m_l2Power(13)=CLng(8192)
    m_l2Power(14)=CLng(16384)
    m_l2Power(15)=CLng(32768)
    m_l2Power(16)=CLng(65536)
    m_l2Power(17)=CLng(131072)
    m_l2Power(18)=CLng(262144)
    m_l2Power(19)=CLng(524288)
    m_l2Power(20)=CLng(1048576)
    m_l2Power(21)=CLng(2097152)
    m_l2Power(22)=CLng(4194304)
    m_l2Power(23)=CLng(8388608)
    m_l2Power(24)=CLng(16777216)
    m_l2Power(25)=CLng(33554432)
    m_l2Power(26)=CLng(67108864)
    m_l2Power(27)=CLng(134217728)
    m_l2Power(28)=CLng(268435456)
    m_l2Power(29)=CLng(536870912)
    m_l2Power(30)=CLng(1073741824)
    Private Function LShift(lValue,iShiftBits)
     If iShiftBits=0 Then
      LShift=lValue
      Exit Function
     ElseIf iShiftBits=31 Then
      If lValue And 1 Then
       LShift=&H80000000
      Else
       LShift=0
      End If
      Exit Function
     ElseIf iShiftBits<0 Or iShiftBits>31 Then
      Err.Raise 6
     End If
     If(lValue And m_l2Power(31-iShiftBits))Then
      LShift=((lValue And m_lOnBits(31-(iShiftBits+1)))*m_l2Power(iShiftBits))Or &H80000000
     Else
      LShift=((lValue And m_lOnBits(31-iShiftBits))*m_l2Power(iShiftBits))
     End If
    End Function
    Private Function RShift(lValue,iShiftBits)
     If iShiftBits=0 Then
      RShift=lValue
      Exit Function
     ElseIf iShiftBits=31 Then
      If lValue And &H80000000 Then
       RShift=1
      Else
       RShift=0
      End If
      Exit Function
     ElseIf iShiftBits<0 Or iShiftBits>31 Then
      Err.Raise 6
     End If
     RShift=(lValue And &H7FFFFFFE)\m_l2Power(iShiftBits)
     If(lValue And &H80000000)Then
      RShift=(RShift Or(&H40000000\m_l2Power(iShiftBits-1)))
     End If
    End Function
    Private Function RotateLeft(lValue,iShiftBits)
     RotateLeft=LShift(lValue,iShiftBits)Or RShift(lValue,(32-iShiftBits))
    End Function
    Private Function AddUnsigned(lX,lY)
     Dim lX4
     Dim lY4
     Dim lX8
     Dim lY8
     Dim lResult
     lX8=lX And &H80000000
     lY8=lY And &H80000000
     lX4=lX And &H40000000
     lY4=lY And &H40000000
     lResult=(lX And &H3FFFFFFF)+(lY And &H3FFFFFFF)
     If lX4 And lY4 Then
      lResult=lResult Xor &H80000000 Xor lX8 Xor lY8
     ElseIf lX4 Or lY4 Then
      If lResult And &H40000000 Then
       lResult=lResult Xor &HC0000000 Xor lX8 Xor lY8
      Else
       lResult=lResult Xor &H40000000 Xor lX8 Xor lY8
      End If
     Else
      lResult=lResult Xor lX8 Xor lY8
     End If
     AddUnsigned=lResult
    End Function
    Private Function F(x,y,z)
     F=(x And y)Or((Not x)And z)
    End Function
    Private Function G(x,y,z)
     G=(x And z)Or(y And(Not z))
    End Function
    Private Function H(x,y,z)
     H=(x Xor y Xor z)
    End Function
    Private Function I(x,y,z)
     I=(y Xor(x Or(Not z)))
    End Function
    Private Sub FF(a,b,c,d,x,s,ac)
     a=AddUnsigned(a,AddUnsigned(AddUnsigned(F(b,c,d),x),ac))
     a=RotateLeft(a,s)
     a=AddUnsigned(a,b)
    End Sub
    Private Sub GG(a,b,c,d,x,s,ac)
     a=AddUnsigned(a,AddUnsigned(AddUnsigned(G(b,c,d),x),ac))
     a=RotateLeft(a,s)
     a=AddUnsigned(a,b)
    End Sub
    Private Sub HH(a,b,c,d,x,s,ac)
     a=AddUnsigned(a,AddUnsigned(AddUnsigned(H(b,c,d),x),ac))
     a=RotateLeft(a,s)
     a=AddUnsigned(a,b)
    End Sub
    Private Sub II(a,b,c,d,x,s,ac)
     a=AddUnsigned(a,AddUnsigned(AddUnsigned(I(b,c,d),x),ac))
     a=RotateLeft(a,s)
     a=AddUnsigned(a,b)
    End Sub
    Private Function ConvertToWordArray(sMessage)
     Dim lMessageLength
     Dim lNumberOfWords
     Dim lWordArray()
     Dim lBytePosition
     Dim lByteCount
     Dim lWordCount
     Const MODULUS_BITS=512
     Const CONGRUENT_BITS=448
     lMessageLength=Len(sMessage)
     lNumberOfWords=(((lMessageLength+((MODULUS_BITS-CONGRUENT_BITS)\BITS_TO_A_BYTE))\(MODULUS_BITS\BITS_TO_A_BYTE))+1)*(MODULUS_BITS\BITS_TO_A_WORD)
     ReDim lWordArray(lNumberOfWords-1)
     lBytePosition=0
     lByteCount=0
     Do Until lByteCount>=lMessageLength
      lWordCount=lByteCount\BYTES_TO_A_WORD
      lBytePosition=(lByteCount Mod BYTES_TO_A_WORD)*BITS_TO_A_BYTE
      lWordArray(lWordCount)=lWordArray(lWordCount)Or LShift(Asc(Mid(sMessage,lByteCount+1,1)),lBytePosition)
      lByteCount=lByteCount+1
     Loop
     lWordCount=lByteCount\BYTES_TO_A_WORD
     lBytePosition=(lByteCount Mod BYTES_TO_A_WORD)*BITS_TO_A_BYTE
     lWordArray(lWordCount)=lWordArray(lWordCount)Or LShift(&H80,lBytePosition)
     lWordArray(lNumberOfWords-2)=LShift(lMessageLength,3)
     lWordArray(lNumberOfWords-1)=RShift(lMessageLength,29)
     ConvertToWordArray=lWordArray
    End Function
    Private Function WordToHex(lValue)
     Dim lByte
     Dim lCount
     For lCount=0 To 3
      lByte=RShift(lValue,lCount*BITS_TO_A_BYTE)And m_lOnBits(BITS_TO_A_BYTE-1)
      WordToHex=WordToHex & Right("0" & Hex(lByte),2)
     Next
    End Function
    Public Function MD5(sMessage)
     Dim x
     Dim k
     Dim AA
     Dim BB
     Dim CC
     Dim DD
     Dim a
     Dim b
     Dim c
     Dim d
     Const S11=7
     Const S12=12
     Const S13=17
     Const S14=22
     Const S21=5
     Const S22=9
     Const S23=14
     Const S24=20
     Const S31=4
     Const S32=11
     Const S33=16
     Const S34=23
     Const S41=6
     Const S42=10
     Const S43=15
     Const S44=21
     x=ConvertToWordArray(sMessage)
     a=&H67452301
     b=&HEFCDAB89
     c=&H98BADCFE
     d=&H10325476
     For k=0 To UBound(x)Step 16
      AA=a
      BB=b
      CC=c
      DD=d
      FF a,b,c,d,x(k+0),S11,&HD76AA478
      FF d,a,b,c,x(k+1),S12,&HE8C7B756
      FF c,d,a,b,x(k+2),S13,&H242070DB
      FF b,c,d,a,x(k+3),S14,&HC1BDCEEE
      FF a,b,c,d,x(k+4),S11,&HF57C0FAF
      FF d,a,b,c,x(k+5),S12,&H4787C62A
      FF c,d,a,b,x(k+6),S13,&HA8304613
      FF b,c,d,a,x(k+7),S14,&HFD469501
      FF a,b,c,d,x(k+8),S11,&H698098D8
      FF d,a,b,c,x(k+9),S12,&H8B44F7AF
      FF c,d,a,b,x(k+10),S13,&HFFFF5BB1
      FF b,c,d,a,x(k+11),S14,&H895CD7BE
      FF a,b,c,d,x(k+12),S11,&H6B901122
      FF d,a,b,c,x(k+13),S12,&HFD987193
      FF c,d,a,b,x(k+14),S13,&HA679438E
      FF b,c,d,a,x(k+15),S14,&H49B40821
      GG a,b,c,d,x(k+1),S21,&HF61E2562
      GG d,a,b,c,x(k+6),S22,&HC040B340
      GG c,d,a,b,x(k+11),S23,&H265E5A51
      GG b,c,d,a,x(k+0),S24,&HE9B6C7AA
      GG a,b,c,d,x(k+5),S21,&HD62F105D
      GG d,a,b,c,x(k+10),S22,&H2441453
      GG c,d,a,b,x(k+15),S23,&HD8A1E681
      GG b,c,d,a,x(k+4),S24,&HE7D3FBC8
      GG a,b,c,d,x(k+9),S21,&H21E1CDE6
      GG d,a,b,c,x(k+14),S22,&HC33707D6
      GG c,d,a,b,x(k+3),S23,&HF4D50D87
      GG b,c,d,a,x(k+8),S24,&H455A14ED
      GG a,b,c,d,x(k+13),S21,&HA9E3E905
      GG d,a,b,c,x(k+2),S22,&HFCEFA3F8
      GG c,d,a,b,x(k+7),S23,&H676F02D9
      GG b,c,d,a,x(k+12),S24,&H8D2A4C8A
      HH a,b,c,d,x(k+5),S31,&HFFFA3942
      HH d,a,b,c,x(k+8),S32,&H8771F681
      HH c,d,a,b,x(k+11),S33,&H6D9D6122
      HH b,c,d,a,x(k+14),S34,&HFDE5380C
      HH a,b,c,d,x(k+1),S31,&HA4BEEA44
      HH d,a,b,c,x(k+4),S32,&H4BDECFA9
      HH c,d,a,b,x(k+7),S33,&HF6BB4B60
      HH b,c,d,a,x(k+10),S34,&HBEBFBC70
      HH a,b,c,d,x(k+13),S31,&H289B7EC6
      HH d,a,b,c,x(k+0),S32,&HEAA127FA
      HH c,d,a,b,x(k+3),S33,&HD4EF3085
      HH b,c,d,a,x(k+6),S34,&H4881D05
      HH a,b,c,d,x(k+9),S31,&HD9D4D039
      HH d,a,b,c,x(k+12),S32,&HE6DB99E5
      HH c,d,a,b,x(k+15),S33,&H1FA27CF8
      HH b,c,d,a,x(k+2),S34,&HC4AC5665
      II a,b,c,d,x(k+0),S41,&HF4292244
      II d,a,b,c,x(k+7),S42,&H432AFF97
      II c,d,a,b,x(k+14),S43,&HAB9423A7
      II b,c,d,a,x(k+5),S44,&HFC93A039
      II a,b,c,d,x(k+12),S41,&H655B59C3
      II d,a,b,c,x(k+3),S42,&H8F0CCC92
      II c,d,a,b,x(k+10),S43,&HFFEFF47D
      II b,c,d,a,x(k+1),S44,&H85845DD1
      II a,b,c,d,x(k+8),S41,&H6FA87E4F
      II d,a,b,c,x(k+15),S42,&HFE2CE6E0
      II c,d,a,b,x(k+6),S43,&HA3014314
      II b,c,d,a,x(k+13),S44,&H4E0811A1
      II a,b,c,d,x(k+4),S41,&HF7537E82
      II d,a,b,c,x(k+11),S42,&HBD3AF235
      II c,d,a,b,x(k+2),S43,&H2AD7D2BB
      II b,c,d,a,x(k+9),S44,&HEB86D391
      a=AddUnsigned(a,AA)
      b=AddUnsigned(b,BB)
      c=AddUnsigned(c,CC)
      d=AddUnsigned(d,DD)
     Next
     MD5=LCase(WordToHex(a)&WordToHex(b)&WordToHex(c)&WordToHex(d))
    End Function
    Public Function SendPost(http,page,host,post)
     With http
      .Open "POST", "http://" & host & page,false
      .setRequestHeader "HOST", host
      .setRequestHeader "Connection", "Keep-Alive"
      .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
      .setRequestHeader "Content-Length", Len(post)
      .Send post
     End With
     SendPost = http.responseText
    End Function
    Public Function Response(xml,pass)
     Set re = new regexp
     re.Pattern = "<Challenge>(\w+)</Challenge>"
     Set match = re.Execute(xml)
     If(match.count > 0) Then
      auth = match(0).SubMatches(0)
      code = ""
      xml = auth & "-" & pass
      For a = 1 To Len(xml)
       code = code & Mid(xml,a,1) & chr(0)
      Next
      Response = "response=" & auth & "-" & md5(code)
     End If
    End Function
    Public Function GetSid(xml)
     Set re = new regexp
     re.Pattern = "<SID>(?!0{16})(\w+)</SID>"
     Set match = re.Execute(xml)
     If(match.count > 0) Then
      GetSid = "sid=" & match(0).SubMatches(0)
     End If
    End Function
    
    Set http = Nothing
    Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
    If http Is Nothing Then Set http = CreateObject("WinHttp.WinHttpRequest.5")
    If http Is Nothing Then Set http = CreateObject("WinHttp.WinHttpRequest")
    If http Is Nothing Then Set http = CreateObject("MSXML2.ServerXMLHTTP")
    If http Is Nothing Then Set http = CreateObject("Microsoft.XMLHTTP")
    If http Is Nothing Then
     ausgabe.writeline "Kein HTTP-Objekt verfügbar!",16,"Fehlermeldung"
    Else
     sid = ""
     page = "/login_sid.lua"
     http.Open "GET", "http://" & host & page,false
     http.Send
     auth = Response(http.responseText,pass)
     If auth <> "" Then
      If auth Then
       If user Then
        auth = auth & "&username=" & user
       End If
       sid = GetSid(SendPost(http,page,host,auth))    ' Einloggen (lua)
      Else
      End If
      If sid = "" Then
       page = "/cgi-bin/webcm"
       data = "getpage=../html/login_sid.xml"
       http.Open "GET", "http://" & host & page & "?" & data,false
       http.Send
       auth = Response(http.responseText,pass)
       If auth Then
        sid = GetSid(SendPost(http,page,host,data & "&login:command/" & auth))    ' Einloggen (cgi)
       Else
        data = SendPost(http,page,host,"login:command/password=" & pass)
       End If
      End If
      If sid <> "" Then
       url = "http://" & host & "//webservices/homeautoswitch.lua?" & sid & "&ain=" & AIN & "&switchcmd=getswitchpower"
       http.Open "GET",url,False
       http.Send  
       Energieaktuell = http.responseText
       Energieaktuell=Energieaktuell/1000
      Else
       ausgabe.writeline "Passwort oder Benutzername möglicherweise falsch! ",vbOKOnly,"Fehlermeldung"
      End If
      
       ausgabe.writeline Energieaktuell
      
      If sid <> "" Then                            ' Ausloggen
       text = SendPost(http,page,host,"security:command/logout=1" & sid)
      End If
     Else
      ausgabe.writeline "Kann die Fritzbox über die Adresse '" & host & "' nicht erreichen! ",vbOKOnly,"Fehlermeldung" 
     End If
    End If
    ausgabe.close

  9. #9
    Registriert seit
    20.06.2003
    Ort
    Sauerland.NRW.Deutschland
    Beiträge
    4.850
    Danke
    78
    Erhielt 800 Danke für 543 Beiträge

    Standard

    welchen fehler?
    ist das verzeichnis c:\fritz vorhanden? das wird nicht automatisch erzeugt.
    die fehlermeldungen in die datei zu schreiben ist auch nicht sonderlich klug. besser mit ' auskommentieren

    bei set eingabe ist ein schreibfehler
    das muss so heissen Set eingabe = fso.openTextFile(eingabedatei, 1)

    hast du mal den link verrfolgt? da stehen hilfreiche sachen für dich drin.
    .
    mfg Volker .......... .. alles wird gut ..

    =>Meine Homepage .. direkt zum Download

    Meine Definition von TIA: Total Inakzeptable Applikation

  10. #10
    Registriert seit
    10.08.2010
    Beiträge
    770
    Danke
    1
    Erhielt 14 Danke für 13 Beiträge

    Standard


    Zuviel Werbung?
    -> Hier kostenlos registrieren
    Hallo
    die datei wird garnicht erst erzeugt.
    Verzeichnis ist nicht vorhanden

Ähnliche Themen

  1. TIA Siemens S7 TIA V13 Basic <> TIA V13 Professional
    Von piksieben im Forum Simatic
    Antworten: 1
    Letzter Beitrag: 05.11.2014, 19:23
  2. TIA TIA V13 upgraden
    Von Brush im Forum Simatic
    Antworten: 2
    Letzter Beitrag: 30.10.2014, 18:24
  3. Antworten: 0
    Letzter Beitrag: 20.10.2014, 20:25
  4. Antworten: 2
    Letzter Beitrag: 11.05.2014, 08:14
  5. TIA TIA Portal V13
    Von TSI09 im Forum Simatic
    Antworten: 6
    Letzter Beitrag: 28.02.2014, 14:25

Lesezeichen

Berechtigungen

  • Neue Themen erstellen: Nein
  • Themen beantworten: Nein
  • Anhänge hochladen: Nein
  • Beiträge bearbeiten: Nein
  •