vbs in Wicc Tia V13 verwenden

emilio20

emilio20

Level-1
Beiträge
835
Reaktionspunkte
20
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
 
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.
 
Zuviel Werbung?
-> Hier kostenlos registrieren
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 ?
 
Hallo

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

Gruß
Aweeller
 
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.
 
Zuviel Werbung?
-> Hier kostenlos registrieren
emilio20 schrieb:
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 ?
Zum Vergrößern anklicken....

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-protool-winccflex-daten-lesen-schreiben-mit-vb-script.html
 
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
 
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
 
Zuviel Werbung?
-> Hier kostenlos registrieren
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.
 
Hallo
wie kann ich mehrere Werte einlesen ?

Text Date
Code: 
1
1
4,54
7,76


Code: 
Dim eingabe,eingabedatei,fso
eingabedatei = "C:\SPS Haussteuerung Projekt\12_FritzDECT200\werte.txt" 'oder was auch immer
Set fso = CreateObject("Scripting.FileSystemObject")
Set eingabe = fso.OpenTextFile(eingabedatei,1)
SmartTags("DECT200_Status") = eingabe.ReadLine

SmartTags("DECT200_VerbindungsStatus") = eingabe.ReadLine

SmartTags("DECT200_Power") = eingabe.ReadLine

SmartTags("DECT200_Energie") = eingabe.ReadLine
eingabe.Close

StartProgram "C:\SPS Haussteuerung Projekt\12_FritzDECT200\DECT200_Werte_Lesen.vbs"," ",hmiShowNormal,hmiNo
 
Zuletzt bearbeitet:
Hallo
wenn ich über das Fritz vbs die Daten eintragen lasse erhalte ich leerzeilen Zwischen den Einträgen.
Warum ist das so ? Wie bekomme ich die Leeren Zeilen weg ?

Code: 
 'Werte der Steckdose in Textdatei speichern
   ausgabe.writeline ("Present;"& Present)
   ausgabe.writeline ("Status;"& Status)
   ausgabe.writeline ("Energieaktuell;"& Energieaktuell)
   ausgabe.writeline ("Energiegesamt;"& Energiegesamt)
 

Anhänge

  • Werte Fritz.JPG
    Werte Fritz.JPG
    13,7 KB · Aufrufe: 13
Zuletzt bearbeitet:

Similar threads

H
WinCC Seltsames Verhalten in VBS Aktion - Bit maskieren funktioniert nicht
Antworten
17
Aufrufe
872
DeltaMikeAir
DeltaMikeAir
S
TIA TIA HMI txt-Datei auslesen
Antworten
9
Aufrufe
3K
PN/DP
PN/DP
T
TIA Inhalt von Textfeld mit Skript ändern
2
Antworten
22
Aufrufe
8K
trabajador73
T
S
TIA Mit Comfort Panel Wetterdaten auslesen
Antworten
3
Aufrufe
5K
Ingmar64
I
A
WinCC VB Skript zum auslesen einer CSV und schreiben in einen DB
Antworten
6
Aufrufe
5K
Amkonianer
A
Zurück
Oben