[Gelöst] Zugriff auf FB Anrufliste mit Microsoft Access

joergINTERNET · 13 Jul 2011

Hallo zusammen,

ich möchte mit Microsoft Access auf die Anrufliste der FritzBox 7390 zugreifen, um die Anrufliste automatisch auswerten zu können.

Der Weg über Export der Liste und Import in Access (CSV) ist mir Bekannt. Ich möchte nun aber einen direkten Zugriff, so dass der Anwender nur Access öffnet und schon die Anrufliste aktuell in einem Bericht zur Verfügung hat.

Ideen für den Zugriff auf die FB?

Vielen Dank!

Gruß Jörg

Pikachu · 13 Jul 2011

Hallo,

Hier: Private Sub FB_Anrufliste_Click()
VBA für MD5
das hatte ich mal kurz als VBA-Makro in Word getestet,
müsste auch mit Access gehen oder?

Code:

' 11.08.2009
' PwdMd5_05.doc
' PwdMd5_05_11082009.bas
' PwdMd5_05_02_11082009.bas
' PwdMd5_05_03_11082009.bas
'
PRIVATE DECLARE FUNCTION CryptAcquireContext LIB "advapi32.dll" _
  ALIAS "CryptAcquireContextA" ( _
  BYREF phProv AS LONG, _
  BYVAL pszContainer AS STRING, _
  BYVAL pszProvider AS STRING, _
  BYVAL dwProvType AS LONG, _
  BYVAL dwFlags AS LONG) AS LONG
'
PRIVATE DECLARE FUNCTION CryptReleaseContext LIB "advapi32.dll" ( _
  BYVAL hProv AS LONG, _
  BYVAL dwFlags AS LONG) AS LONG
'
PRIVATE DECLARE FUNCTION CryptCreateHash LIB "advapi32.dll" ( _
  BYVAL hProv AS LONG, _
  BYVAL Algid AS LONG, _
  BYVAL hKey AS LONG, _
  BYVAL dwFlags AS LONG, _
  BYREF phHash AS LONG) AS LONG
'
PRIVATE DECLARE FUNCTION CryptDestroyHash LIB "advapi32.dll" ( _
  BYVAL hHash AS LONG) AS LONG
'
PRIVATE DECLARE FUNCTION CryptHashData LIB "advapi32.dll" ( _
  BYVAL hHash AS LONG, _
  pbData AS BYTE, _
  BYVAL dwDataLen AS LONG, _
  BYVAL dwFlags AS LONG) AS LONG
'
PRIVATE DECLARE FUNCTION CryptGetHashParam LIB "advapi32.dll" ( _
  BYVAL hHash AS LONG, _
  BYVAL dwParam AS LONG, _
  pbData AS ANY, _
  pdwDataLen AS LONG, _
  BYVAL dwFlags AS LONG) AS LONG
'
'
'
'
' PwdMd5_VBA.bas 27.07.2009
'
Public FUNCTION makeDots(sInStr AS STRING) AS STRING
' Unicode Zeichen die >255 (8364 = ¤) sind mit 46(.) ersetzen
'
 DIM nTmp AS LONG
 DIM sUstr AS STRING
'
 sUstr = sInStr
'
 FOR nTmp = 1 TO LEN(sUstr)
  IF AscW(MID$(sUstr, nTmp, 1)) > 255 THEN
   MID$(sUstr, nTmp) = "."
  END IF
 NEXT nTmp
'
 makeDots = sUstr
'
END FUNCTION
'
'
Public FUNCTION InMD5(sTEXT AS STRING) AS STRING
'
    DIM AcquireContext AS LONG
    DIM HashHandle AS LONG
    DIM result AS LONG
    DIM LaengeResult AS LONG
    DIM Zaehler AS INTEGER
    DIM sTmp AS STRING
    DIM nTmp1 AS LONG
    DIM nTmpLen AS LONG
'
    sTmp = StrConv(sTEXT, vbUnicode)
    REDIM ByteText(0 TO LEN(sTmp)) AS BYTE
    FOR nTmp1 = 0 TO (LEN(sTmp) - 1)
     ByteText(nTmp1) = AscB(MID$(sTmp, (1 + nTmp1), 1))
    NEXT nTmp1
    nTmpLen = LEN(sTmp)
'
    'Ermittle Context Handle
    result = CryptAcquireContext(AcquireContext, vbNullString, vbNullString, _
                                 1, 0)
    IF result = 0 AND Err.LastDllError = &H80090016 THEN
        result = CryptAcquireContext(AcquireContext, vbNullString, _
                                     vbNullString, 1, &H8)
    END IF
    result = CryptCreateHash(AcquireContext, 32771, 0, 0, HashHandle)
'
    result = CryptHashData(HashHandle, ByteText(0), nTmpLen, 0)
'
    result = CryptGetHashParam(HashHandle, 4, LaengeResult, 4, 0)
    REDIM ByteResult(0 TO LaengeResult - 1) AS BYTE
    result = CryptGetHashParam(HashHandle, 2, ByteResult(0), LaengeResult, 0)
    FOR Zaehler = 0 TO UBOUND(ByteResult)
        InMD5 = InMD5 & RIGHT$("0" & HEX$(ByteResult(Zaehler)), 2)
    NEXT Zaehler
    CryptDestroyHash HashHandle
    CryptReleaseContext AcquireContext, 0
'
END FUNCTION
'
'
'
'
Public Function FFSP_Login_Sid(sHost As String, sPassword As String, sSID As String) As Long
'
 Dim sMode As String, sLink As String, sFormdata As String
 Dim Iswriteaccess As String, sChallenge As String, sResponse As String
 Dim sRetHTTPTransferRT As String
 Dim sA As String, sB As String, sC As String, sD As String
 Dim nPosition As Long, nLength As Long
 Dim nPosition2 As Long, nLength2 As Long
 Dim nRet1 As Long, nRet2 As Long
'
 Static sRetSID As String
'
 FFSP_Login_Sid = 0: nRet1 = 0: nRet2 = 0
 Iswriteaccess = "": sChallenge = "": sResponse = "": sSID = ""
'
 If Trim$(sHost) = "" Or Trim$(sPassword) = "" Then Exit Function ' 04.12.2010
'
 sMode = "POST "
 sLink = "http://" + sHost + "/cgi-bin/webcm"
'
 If sRetSID <> "" Then
  sFormdata = "sid=" + sRetSID + "&" + "getpage=../html/login_sid.xml"
 Else
  sFormdata = "getpage=../html/login_sid.xml"
 End If
'
 sRetHTTPTransferRT = HTTPTransferRT(sMode, sLink, sFormdata)
'
'iswriteaccess
 nPosition = 1: nLength = 0: nPosition2 = 0: nLength2 = 0
'
' login_sid.xml
' sRetHTTPTransferRT = " <SessionInfo> <iswriteaccess> 01 </iswriteaccess> <SID>0000000000000001</SID> <Challenge>6ad690f8</Challenge> </SessionInfo> "
' sRetHTTPTransferRT = " <SessionInfo> <iswriteaccess> 0 </iswriteaccess> <SID>0000000000000000</SID> <Challenge>6ad690f8</Challenge> </SessionInfo> "
 sA = sRetHTTPTransferRT
 sB = "<iswriteaccess>"
'
 nPosition = InStr(nPosition, sA, sB, vbTextCompare)
 nLength = Len(sB)
 If (nPosition > 0) And (nLength > 0) Then
  sD = Mid$(sA, nPosition, nLength)
'
  sB = "</iswriteaccess>"
  nPosition = nPosition + nLength
  nPosition2 = InStr(nPosition, sA, sB, vbTextCompare)
  nLength2 = Len(sB)
  If (nPosition2 > 0) And (nPosition < nPosition2) And (nLength2 > 0) Then
   sD = Mid$(sA, nPosition, (nPosition2 - nPosition) + (nLength2 - Len(sB)))
   nRet1 = 1
'   sIswriteaccess = Trim$(sD)
   sIswriteaccess = sRetainAny(sD, "01")
'   If Val(sIswriteaccess) >= 1 Then
   If Val("&H" + sIswriteaccess) >= 1 Then
    sIswriteaccess = "1"
    nRet2 = 1
'   ElseIf Val(sIswriteaccess) = 0 Then
   ElseIf Val("&H" + sIswriteaccess) = 0 Then
    sIswriteaccess = "0"
    nRet1 = 2
    nRet2 = 2
   End If
  Else
   nRet1 = 2
  End If
'
 Else
  nRet1 = 2
 End If
'
'MsgBox Str$(nRet1) + "  -1-  " + Str$(nRet2) + "   " + sD
'
 If (nRet1 = 2) And (nRet2 = 2) Then
'
' Challenge
  nPosition = 1: nLength = 0: nPosition2 = 0: nLength2 = 0
  sA = sRetHTTPTransferRT
  sB = "<Challenge>"
'
  nPosition = InStr(nPosition, sA, sB, vbTextCompare)
  nLength = Len(sB)
  If (nPosition > 0) And (nLength > 0) Then
   sD = Mid$(sA, nPosition, nLength)
'
   sB = "</Challenge>"
   nPosition = nPosition + nLength
   nPosition2 = InStr(nPosition, sA, sB, vbTextCompare)
   nLength2 = Len(sB)
   If (nPosition2 > 0) And (nPosition < nPosition2) And (nLength2 > 0) Then
    sD = Mid$(sA, nPosition, (nPosition2 - nPosition) + (nLength2 - Len(sB)))
    nRet1 = 1
    sChallenge = Trim$(sD)
'
    sResponse = sChallenge + "-" + LCase$(InMD5(sChallenge + "-" + makeDots(sPassword)))
' 19.08.2011 ' login_sid.xml
        sFormdata = "getpage=../html/login_sid.xml"
        sFormdata = sFormdata + "&login:command/response=" + sResponse
'
'    sFormdata = "getpage=../html/de/menus/menu2.html&login:command/response=" + sResponse
'
    sRetHTTPTransferRT = HTTPTransferRT(sMode, sLink, sFormdata)
' Response
'sRetHTTPTransferRT = "<input type=" + Chr$(34) + "hidden" + Chr$(34) + " name=" + Chr$(34) + "sid" + Chr$(34) + " value=" + Chr$(34) + "13e41555bcc92250" + Chr$(34) + " id=" + Chr$(34) + "uiPostSid" + Chr$(34) + ">"
'
    If sRetHTTPTransferRT = "" Then ' de/menus/menu2.html 19.08.2011 ' login_sid.xml
'
     FFSP_Login_Sid = 0: nRet1 = 0: nRet2 = 0
     Iswriteaccess = "": sChallenge = "": sResponse = "": sSID = ""
'
     sMode = "POST "
     sLink = "http://" + sHost + "/cgi-bin/webcm"
'
     If sRetSID <> "" Then
      sFormdata = "sid=" + sRetSID + "&" + "getpage=../html/login_sid.xml"
     Else
      sFormdata = "getpage=../html/login_sid.xml"
     End If
'
     sRetHTTPTransferRT = HTTPTransferRT(sMode, sLink, sFormdata)
'
'iswriteaccess
     nPosition = 1: nLength = 0: nPosition2 = 0: nLength2 = 0
'
     sA = sRetHTTPTransferRT
     sB = "<iswriteaccess>"
'
     nPosition = InStr(nPosition, sA, sB, vbTextCompare)
     nLength = Len(sB)
     If (nPosition > 0) And (nLength > 0) Then
      sD = Mid$(sA, nPosition, nLength)
'
      sB = "</iswriteaccess>"
      nPosition = nPosition + nLength
      nPosition2 = InStr(nPosition, sA, sB, vbTextCompare)
      nLength2 = Len(sB)
      If (nPosition2 > 0) And (nPosition < nPosition2) And (nLength2 > 0) Then
       sD = Mid$(sA, nPosition, (nPosition2 - nPosition) + (nLength2 - Len(sB)))
       nRet1 = 1
       sIswriteaccess = sRetainAny(sD, "01")
       If Val("&H" + sIswriteaccess) >= 1 Then
        sIswriteaccess = "1"
        nRet2 = 1
       ElseIf Val("&H" + sIswriteaccess) = 0 Then
        sIswriteaccess = "0"
        nRet1 = 2
        nRet2 = 2
       End If
      Else
       nRet1 = 2
      End If
'
     Else
      nRet1 = 2
     End If
'
     If (nRet1 = 2) And (nRet2 = 2) Then
'
' Challenge
      nPosition = 1: nLength = 0: nPosition2 = 0: nLength2 = 0
      sA = sRetHTTPTransferRT
      sB = "<Challenge>"
'
      nPosition = InStr(nPosition, sA, sB, vbTextCompare)
      nLength = Len(sB)
      If (nPosition > 0) And (nLength > 0) Then
       sD = Mid$(sA, nPosition, nLength)
'
       sB = "</Challenge>"
       nPosition = nPosition + nLength
       nPosition2 = InStr(nPosition, sA, sB, vbTextCompare)
       nLength2 = Len(sB)
       If (nPosition2 > 0) And (nPosition < nPosition2) And (nLength2 > 0) Then
        sD = Mid$(sA, nPosition, (nPosition2 - nPosition) + (nLength2 - Len(sB)))
        nRet1 = 1
        sChallenge = Trim$(sD)
'
        sResponse = sChallenge + "-" + LCase$(InMD5(sChallenge + "-" + makeDots(sPassword)))
'
'        sFormdata = "getpage=../html/login_sid.xml"
'        sFormdata = sFormdata + "&login:command/response=" + sResponse
' 19.08.2011 de/menus/menu2.html
        sFormdata = "getpage=../html/de/menus/menu2.html&login:command/response=" + sResponse
'
        sRetHTTPTransferRT = HTTPTransferRT(sMode, sLink, sFormdata)
' Response
' sRetHTTPTransferRT = " <SessionInfo> <iswriteaccess> 1 </iswriteaccess> <SID>13e41555bcc92250</SID> <Challenge>6ad690f8</Challenge> </SessionInfo> "
'
       End If
'
      End If
'
     End If
'
    End If
'
    If sRetHTTPTransferRT = "" Then
     nRet1 = 2
    ElseIf sRetHTTPTransferRT <> "" Then
     nRet1 = 1
    End If
'
   Else
    nRet1 = 2
   End If
'
  Else
   nRet1 = 2
  End If
'
 End If
'
'MsgBox Str$(nRet1) + "  -2-  " + Str$(nRet2) + "   " + sD
'
 If nRet1 = 2 Then
'
  sFormdata = "getpage=../html/de/menus/menu2.html&login:command/password=" + sPassword
'
  sRetHTTPTransferRT = HTTPTransferRT(sMode, sLink, sFormdata)
'
  If sRetHTTPTransferRT = "" Then
   nRet1 = 1
  ElseIf sRetHTTPTransferRT <> "" Then
   nRet1 = 2
  End If
'
 ElseIf nRet1 = 1 Then
'
' SessionID
  nPosition = 1: nLength = 0: nPosition2 = 0: nLength2 = 0
  sA = sRetHTTPTransferRT
  sB = "<SID>"
'
  nPosition = InStr(nPosition, sA, sB, vbTextCompare)
  nLength = Len(sB)
  If (nPosition > 0) And (nLength > 0) Then
   sD = Mid$(sA, nPosition, nLength)
'
   sB = "</SID>"
   nPosition = nPosition + nLength
   nPosition2 = InStr(nPosition, sA, sB, vbTextCompare)
   nLength2 = Len(sB)
   If (nPosition2 > 0) And (nPosition < nPosition2) And (nLength2 > 0) Then
    sD = Mid$(sA, nPosition, (nPosition2 - nPosition) + (nLength2 - Len(sB)))
    nRet1 = 1
'
'    sSID = Trim$(sD)
    sSID = LCase$(sRetainAny(sD, "0123456789abcdefABCDEF"))
'
    If Val("&H" + sSID) = 0 Then
     nRet1 = 2
    End If
'
   Else
    nRet1 = 2
   End If
'
  Else
   nRet1 = 2
  End If
'
 End If
'
'MsgBox Str$(nRet1) + "  -3-  " + Str$(nRet2) + "   " + sD + "   " + sSID
'
 If nRet1 = 2 Then
'
' SessionID
  nPosition = 1: nLength = 0: nPosition2 = 0: nLength2 = 0
  sA = sRetHTTPTransferRT
'
  sB = "name=" + Chr$(34) + "sid" + Chr$(34)
'
  nPosition = InStr(nPosition, sA, sB, vbTextCompare)
  nLength = Len(sB)
  If (nPosition > 0) And (nLength > 0) Then
   sD = Mid$(sA, nPosition, nLength)
'MsgBox Str$(nPosition2) + "  -3a-  " + sD
'
   sB = "value"
   nPosition = nPosition + nLength
   nPosition2 = InStr(nPosition, sA, sB, vbTextCompare)
   nLength2 = Len(sB)
   If (nPosition2 > 0) And (nPosition < nPosition2) And (nLength2 > 0) Then
'
   sD = Mid$(sA, nPosition2, nLength2)
'MsgBox Str$(nPosition2) + "  -3a-  " + sD

    sB = Chr$(34)
    nLength2 = nLength2 '+ Len(sB) - 1
    nPosition = nPosition2 + nLength2
    nPosition2 = InStr(nPosition, sA, sB, vbTextCompare)
'
    If (nPosition2 > 0) And (nPosition < nPosition2) And (nLength2 > 0) Then
'
   sD = Mid$(sA, nPosition2, nLength2)
'MsgBox Str$(nPosition2) + "  -3aa-  " + sD

     sB = Chr$(34)
     nLength2 = Len(sB)
     nPosition = nPosition2 + nLength2
     nPosition2 = InStr(nPosition, sA, sB, vbTextCompare)
'
     sD = Mid$(sA, nPosition, (nPosition2 - nPosition) + (nLength2 - Len(sB)))
'MsgBox Str$(nPosition2) + "  -3b-  " + sD
'
     If (nPosition2 > 0) And (nPosition < nPosition2) And (nLength2 > 0) Then
'
      nRet1 = 1
'
'      sSID = Trim$(sD)
      sSID = LCase$(sRetainAny(sD, "0123456789abcdefABCDEF"))
'
      If Val("&H" + sSID) = 0 Then
'MsgBox Str$(nPosition2) + "  -3c-  " + CStr(Val("&H" + sSID))
       nRet1 = 2
      End If
'
     Else
      nRet1 = 2
     End If
'
    Else
     nRet1 = 2
    End If
'
   Else
    nRet1 = 2
   End If
'
  Else
   nRet1 = 2
  End If
'
 End If
'
'MsgBox Str$(nRet1) + "  -4-  " + Str$(nRet2) + "   " + sD + "   " + sSID
'
 FFSP_Login_Sid = nRet1
'
' Response
' <input type="hidden" name="sid" value="13e41555bcc92250" id="uiPostSid">
' <input type="hidden" name="sid" value="0000000000000000" id="uiPostSid">
'
 If nRet1 = 1 Then
  sRetSID = sSID
 Else
  sRetSID = ""
 End If
'
End Function
'
'
'
'
FUNCTION HTTPTransferRT(sMode AS STRING, sLink AS STRING, sFormdata AS STRING) AS STRING
' Link: Link zur Webpage
' Mode "Get" oder "Post"
' Microsoft WinHTTP Services, version 5.1
'
 DIM nV1 AS LONG, nV2 AS LONG, nV3 AS LONG
 DIM sV1 AS STRING, sV2 AS STRING, sV3 AS STRING
 DIM nL1 AS LONG, nL2 AS LONG
'
 DIM objXMLHTTP AS NEW WinHttp.WinHttpRequest
' Dim objXMLHTTP As New MSXML2.XMLHTTP40
'
 sV1 = sMode ' "GET " oder "POST "
 sV2 = sLink ' "http://192.168.2.1/html/top_start_passwort.htm"
 nV3 = 0
'
 objXMLHTTP.Open sV1, sV2, nV3
'
 sV1 = "Content-Type"
 sV2 = "application/x-www-form-urlencoded"
 objXMLHTTP.setRequestHeader sV1, sV2
'
 sV1 = sFormdata
 objXMLHTTP.SEND sV1
 '
' nL1 = objXMLHTTP.readyState ' "Msxml2.XMLHTTP.4.0"
 nL2 = objXMLHTTP.Status
'
' If nL1 = 4 And nL2 = 200 Then ' "Msxml2.XMLHTTP.4.0"
' If nL1 = 0 And nL2 = 200 Then ' "WinHttp.WinHttpRequest.5.1"
 IF nL1 = 0 AND nL2 = 200 THEN
'
  sV1 = objXMLHTTP.responseText
  HTTPTransferRT = sV1
'
 END IF
'
END FUNCTION
'
'
'
'
FUNCTION FFSP_Logout_Sid(sHost AS STRING, sSID AS STRING) AS LONG
'
 DIM sMode AS STRING, sLink AS STRING, sFormdata AS STRING
 DIM sRetHTTPTransferRT AS STRING
'
 FFSP_Logout_Sid = 0
'
 sMode = "POST "
 sLink = "http://" + sHost + "/cgi-bin/webcm"
 IF LEN(sSID) > 0 THEN
'  sFormdata = "getpage=../html/de/menus/menu2.html&sid=" + sSID + "&security:command/logout=&getpage=../html/confirm_logout.html"
  sFormdata = "sid=" + sSID + "&security:command/logout=&getpage=../html/confirm_logout.html" ' 21.12.2010 FB 7390
 ELSE
'  sFormdata = "getpage=../html/de/menus/menu2.html&security:command/logout=" + "beenden"
  sFormdata = "getpage=../html/de/menus/menu2.html&security:command/logout=" + "1"
 END IF
'
 sRetHTTPTransferRT = HTTPTransferRT(sMode, sLink, sFormdata)
'
 IF sRetHTTPTransferRT = "" THEN
  FFSP_Logout_Sid = 1
 ELSEIF sRetHTTPTransferRT <> "" THEN
  FFSP_Logout_Sid = 2
 END IF
'
END FUNCTION
'
'
'
'
FUNCTION sRetainAny(sStrIn AS STRING, sStrInAny AS STRING) AS STRING
' 10.08.2009
' Liefert alle Zeichen von sStrInAny die in sStrIn enthalten sind zurueck
'
 DIM sTmp AS STRING, sTmp1 AS STRING
 DIM nTmp AS LONG, nTmp1 AS LONG
 DIM sStrInTmp AS STRING, sStrInAnyTmp AS STRING
 DIM nStrInTmp AS LONG, nStrInAnyTmp AS LONG
 DIM nStrInTmpLen AS LONG, nStrInAnyTmpLen AS LONG
 DIM sStrOut AS STRING
'
 sStrOut = ""
'
 IF sStrIn <> "" THEN
  IF sStrInAny <> "" THEN
'
   sStrInTmp = sStrIn: sStrInAnyTmp = sStrInAny
   nStrInTmpLen = LEN(sStrIn): nStrInAnyTmpLen = LEN(sStrInAny)
'
   IF (nStrInTmpLen > 0) AND (nStrInAnyTmpLen > 0) THEN
'
    FOR nTmp = 1 TO nStrInTmpLen
'
     sTmp = MID$(sStrInTmp, nTmp, 1)
'
     FOR nTmp1 = 1 TO nStrInAnyTmpLen
'
      sTmp1 = MID$(sStrInAnyTmp, nTmp1, 1)
'
      IF sTmp1 = sTmp THEN
       sStrOut = sStrOut + sTmp
       EXIT FOR
      END IF
'
     NEXT nTmp1
'
    NEXT nTmp
'
    IF LEN(sStrOut) > 0 THEN sRetainAny = sStrOut
'
   END IF
'
  END IF
'
 END IF
'
END FUNCTION
'
'

Gruß Erwin

joergINTERNET · 13 Jul 2011

Hallo Erwin,

herzlichen Dank. Ich probiere das jetzt erst mal in Word, um nicht gleich zu viele Änderungen zu haben.
Ich habe den Code jetzt mal in ein Word-VBA-Modul importiert.
Welche Funktion muss ich denn ausführen, damit was passiert?

Danke, VG Jörg

Pikachu · 14 Jul 2011

Hallo,

Hier: PwdMd5_05_03.doc
per Anhang der kleine Test unter Word 2000,
da ging es nur um den SessionID Login, die Anrufliste abrufen ist dabei nur ein Test.

Änderung hier: PwdMd5_05_03_19082011_doc_Word_2000.zip -> SessionID Login ab Firmware .05.05 dazugefügt

Gruß Erwin

joergINTERNET · 14 Jul 2011

Hi Erwin,

super, ganz herzlichen Dank!

VG Jörg

joergINTERNET · 14 Jul 2011

Hi ERwin,

ich muss Dich leider noch mal was fragen.
Das Formular hab´ ich geladen, die Host IP stimmt, das Passwort hab´ ich eingetragen. Dann klicke ich auf Anrufliste.
Er schreibt dann im Formular bei 4 folgendes rein: 0000 und bei 5 folgendes: 2

Was ich noch nicht verstehe ist, wo dann die Anrufliste auftaucht oder wie ich die abfangen kann.

Danke, VG Jörg

Pikachu · 14 Jul 2011

Hallo,

Sorry, hätte Ich reinschreiben müssen, wenn du
in der TextBox für das Passwort ein Passwort einträgst
dann musst du es mit dem Button makeDot in die TextBox makeDot übernehmen,
wegen UniCode Zeichen.

Du kannst aber auch hier:

Code:

Const sFritzBoxIP = "192.168.178.1" ' "fritz.box" ' "speedport.ip"
Const sFritzBoxPWD = "0000"

Passwort und IP vorgeben.

Wenn du auf Anrufliste Klickst dann sollte in der grossen TextBox
die List erscheinen.

TextBox 5 -> 1 für OK / 2 für einen Fehler -> PW oder IP Falsch oder LogIn-Out Fehler

Gruß Erwin

joergINTERNET · 14 Jul 2011

Hi Erwin,

danke für den Tipp.
Ich hab es jetzt direkt in die Constante geschrieben.
Leider kommt nun nach dem Klick auf Anrufliste folgende Fehlermeldung:

Laufzeitfehler:
Für das Unicode-Zeichen ist kein zugeordnetes Zeichen in der Mehrbytecodepage vorhanden.

Beim Debuggen ist der Fehler in der Function HTTPTransferRT in der Zeile sV1=objXMLHTTP.responseTEXT

VG Jörg

Pikachu · 14 Jul 2011

Hallo,

Der Fehler Taucht bei mir in Word 2000 zwar nicht auf,
aber ein ähnlicher wenn die winhttp.dll nicht Aktiviert wurde
wie auf dem jpg Bild: VBA_WinHTTP.jpg

In VBA Extras Verweise Project
Bei Microsoft WinHTTP Services, version 5.1 einen Haken setzen

Gruß Erwin

joergINTERNET · 14 Jul 2011

Hi Erwin,

Word 2000 hab ich leider nicht, nur Word 2010.
Haken war gesetzt. Ich hab ihn jetzt mal raus und dann wieder rein.
Leider noch immer der gleiche Fehler :-(

VG Jörg

Pikachu · 14 Jul 2011

Hallo,

Habe hier mal die Variable von String in 'Dim sV10 As Variant' ersetzt
vielleicht hilft das Frage.

Schau auch mal in den Objektkatalog was dort drin steht
bei WinHttp WinHttpRequest für ResponseText

Code:

'
Function HTTPTransferRT(sMode As String, sLink As String, sFormdata As String) As String
' Link: Link zur Webpage
' Mode "Get" oder "Post"
' Microsoft WinHTTP Services, version 5.1
'
 Dim nV1 As Long, nV2 As Long, nV3 As Long
 Dim sV1 As String, sV2 As String, sV3 As String
 Dim sV10 As Variant
 Dim nL1 As Long, nL2 As Long
'
 Dim objXMLHTTP As New WinHttp.WinHttpRequest
' Dim objXMLHTTP As New MSXML2.XMLHTTP40
'
 sV1 = sMode ' "GET " oder "POST "
 sV2 = sLink ' "http://192.168.2.1/html/top_start_passwort.htm"
 nV3 = 0
'
 objXMLHTTP.Open sV1, sV2, nV3
'
 sV1 = "Content-Type"
 sV2 = "application/x-www-form-urlencoded"
 objXMLHTTP.setRequestHeader sV1, sV2
'
 sV1 = sFormdata
 objXMLHTTP.SEND sV1
 '
' nL1 = objXMLHTTP.readyState ' "Msxml2.XMLHTTP.4.0"
 nL2 = objXMLHTTP.Status
'
' If nL1 = 4 And nL2 = 200 Then ' "Msxml2.XMLHTTP.4.0"
' If nL1 = 0 And nL2 = 200 Then ' "WinHttp.WinHttpRequest.5.1"
 If nL1 = 0 And nL2 = 200 Then
'
'  sV1 = objXMLHTTP.responseText
  sV10 = objXMLHTTP.responseText
'  HTTPTransferRT = sV1
  HTTPTransferRT = sV10
'
 End If
'
End Function
'

Oder es Fehlt noch was hier im Bild: VBA_WinHTTP_1.png

Gruß Erwin

joergINTERNET · 14 Jul 2011

Hi Erwin,

Haken sind gesetzt, Funktion durch den neuen Code ersetzt.
Leider weiter der gleiche Fehler.

Brauche ich denn sonst noch was in der Umgebung?
Momentan läuft alles unter Windows 7, Word 2010, Google Chrome

VG Jörg

Pikachu · 14 Jul 2011

Sorry, leider hilft mir Google auch nicht dabei aber es scheint wohl
irgendeine Datei / Dll usw. nicht kompatible zu sein.

Hier: Visual Basic for Applications Runtime-Sicherheitsupdate
noch ein VBA Update wenn nicht schon vorhanden.

Das hier: Service Pack 6 für Visual Basic 6.0: Redistributionspaket für Visual Basic-Laufzeitdateien (vbrun60sp6.exe)
wird wohl unter W7 nicht gehen oder?!

Gruß Erwin

Kruemelino · 15 Jul 2011

Pikachu hat mich heute um 9 auf das Problem aufmerksamgemacht. Seit dem habe ich mich mit deinem Problem beschäftigt. Ich habe diverse Erfahrung mit dem SessionID-Verfahren von AVM.

Dein Makro arbeitet recht zuverlässig. Deine Fehlermeldung liegt definitiv an der der Funktion "HTTPTransferRT". Frag mich jetzt nicht was da das Problem ist.

Ich habe folgendem Lösungsvorschlag.

Setze einen Verweis auf Microsoft XML, v6.0.

Ersetze die Funktion "HTTPTransferRT" durch die:

Code:

Function HTTPTransferRT(Mode As String, Link As String, formdata As String) As String
    ' Link: Link zur Webpage
    ' Mode "Get" oder "Post"
    
    Dim http        As New MSXML2.XMLHTTP30
    http.Open Mode, Link, False
    http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    On Error Resume Next
    http.Send formdata
    On Error GoTo 0
    If http.readyState = 4 Then HTTPTransferRT = StrConv(http.ResponseBody, vbUnicode)


End Function '(HTTPTransfer)

Sie macht eigentlich genau das gleiche wie deine Funktion, nur mit XML-HTTP 3.0. Bei mir (Office 2010, x64) hat es gerade funktioniert. Im Anhang findest du meine Testroutine für das SessionID-Verfahren für vb.NET.

Ich hoffe es klappt bei dir dann auch

Kruemel

joergINTERNET · 15 Jul 2011

hi erwin,

updates habe ich gemacht, leider funktioniert es weiter nicht.
lass es gut sein, ich muss es dann eben anders lösen.
vielen herzlichen dank aber für deine mühen!
schönes we!

vg jörg

joergINTERNET · 15 Jul 2011

Hi Kruemel,

herzlichen Dank, das werd´ ich gleich noch probieren.

VG Jörg

joergINTERNET · 15 Jul 2011

Hi Kruemel und Erwin,

toll. es funktioniert.

Vielen vielen Dank!

VG Jörg

Pikachu · 15 Jul 2011

Hallo,

Danke Kruemelino, jetzt weiß ich warum das in Rem MSXML2.XMLHTTP40 stehende
bei mir nicht ging es geht wohl nur mit MSXML2.XMLHTTP30
warum auch immer.
Wenn Ich jetzt diese Zeile HTTPTransferRT = objXMLHTTP.responseText
mit HTTPTransferRT = StrConv(objXMLHTTP.ResponseBody, vbUnicode) ersetze.

Hier:

' Microsoft WinHTTP Services, version 5.1

Code:

Function HTTPTransferRT(sMode As String, sLink As String, sFormdata As String) As String
' Link: Link zur Webpage
' Mode "Get" oder "Post"
' Microsoft WinHTTP Services, version 5.1
' Microsoft XML, v6.0 / Microsoft XML, v4.0 / Microsoft XML, v3.0
'
 Dim nV1 As Long, nV2 As Long, nV3 As Long
 Dim sV1 As String, sV2 As String, sV3 As String
 Dim nL1 As Long, nL2 As Long
'
 Dim objXMLHTTP As New WinHttp.WinHttpRequest
' Dim objXMLHTTP As New MSXML2.XMLHTTP30
'
 sV1 = sMode ' "GET " oder "POST "
 sV2 = sLink ' "http://192.168.2.1/html/top_start_passwort.htm"
 nV3 = 0
'
 objXMLHTTP.Open sV1, sV2, nV3
'
 sV1 = "Content-Type"
 sV2 = "application/x-www-form-urlencoded"
 objXMLHTTP.setRequestHeader sV1, sV2
'
 sV1 = sFormdata
 objXMLHTTP.Send sV1
 '
' nL1 = objXMLHTTP.readyState ' "Msxml2.XMLHTTP.3.0"
 nL2 = objXMLHTTP.Status
'
' If nL1 = 4 And nL2 = 200 Then ' "Msxml2.XMLHTTP.3.0"
' If nL1 = 0 And nL2 = 200 Then ' "WinHttp.WinHttpRequest.5.1"
 If nL1 = 0 And nL2 = 200 Then
'
'  sV1 = objXMLHTTP.responseText
'  HTTPTransferRT = sV1
  HTTPTransferRT = StrConv(objXMLHTTP.ResponseBody, vbUnicode)
'
 End If
'
End Function

' Microsoft XML, v6.0 / Microsoft XML, v4.0 / Microsoft XML, v3.0

Code:

Function HTTPTransferRT(sMode As String, sLink As String, sFormdata As String) As String
' Link: Link zur Webpage
' Mode "Get" oder "Post"
' Microsoft WinHTTP Services, version 5.1
' Microsoft XML, v6.0 / Microsoft XML, v4.0 / Microsoft XML, v3.0
'
 Dim nV1 As Long, nV2 As Long, nV3 As Long
 Dim sV1 As String, sV2 As String, sV3 As String
 Dim nL1 As Long, nL2 As Long
'
' Dim objXMLHTTP As New WinHttp.WinHttpRequest
 Dim objXMLHTTP As New MSXML2.XMLHTTP30
'
 sV1 = sMode ' "GET " oder "POST "
 sV2 = sLink ' "http://192.168.2.1/html/top_start_passwort.htm"
 nV3 = 0
'
 objXMLHTTP.Open sV1, sV2, nV3
'
 sV1 = "Content-Type"
 sV2 = "application/x-www-form-urlencoded"
 objXMLHTTP.setRequestHeader sV1, sV2
'
 sV1 = sFormdata
 objXMLHTTP.Send sV1
 '
 nL1 = objXMLHTTP.readyState ' "Msxml2.XMLHTTP.3.0"
 nL2 = objXMLHTTP.Status
'
 If nL1 = 4 And nL2 = 200 Then ' "Msxml2.XMLHTTP.3.0"
' If nL1 = 0 And nL2 = 200 Then ' "WinHttp.WinHttpRequest.5.1"
' If nL1 = 0 And nL2 = 200 Then
'
'  sV1 = objXMLHTTP.responseText
'  HTTPTransferRT = sV1
  HTTPTransferRT = StrConv(objXMLHTTP.ResponseBody, vbUnicode)
'
 End If
'
End Function

Bei Aktuellen FritzBoxen kann man die Anruliste auch als XML Datei: foncallsdaten.xml
Auslesen, diese ist dann in UTF-8 nicht iso-8859-1

Das hier:

Code:

'   sFormdata = "sid=" + sSID + "&" + "getpage=../html/de/FRITZ!Box_Anrufliste.csv" ' FRITZ!Box_Anrufliste.csv FRITZ!Box
   sFormdata = "sid=" + sSID + "&" + "getpage=../html/de/home/foncallsdaten.xml" ' foncallsdaten.xml XML Anrufliste FRITZ!Box

kannst du ja mal Testen, da Access 2010 das XML Format kann dürfte damit die
Datenübernahme einfacher sein als mit der CSV Datei.

Gruß Erwin

joergINTERNET · 15 Jul 2011

Hi Ihr zwei Profis,

der letzte Post zeigt das aktuelle Problem, das ich habe.
Ich hab jetzt eine Access MDB, eine passende Tabelle und eine Routine "rs.add" erstellt,
Das hinzufügen von Daten (manuell) funktioniert gut.

Über welche Funktion von Erwins Code bekomme ich nun die Daten der Anrufliste in welchem Format zurück, damit ich diese der Tabelle hinzufügen kann?

Danke, VG Jörg

Kruemelino · 15 Jul 2011

Pikachu schrieb:
Hallo,

[...]

kannst du ja mal Testen, da Access 2010 das XML Format kann dürfte damit die
Datenübernahme einfacher sein als mit der CSV Datei.

Gruß Erwin

Für mich ist das Jacke wie Hose.
Die csv lässt sich super zeilenweise auswerten:

Die csv mit

Code:

Split(CSVAnrliste, Chr(10), , CompareMethod.Text)

zeilenweise zwerlegen

Danach jede Zeile mit
Code:
```
Split(CStr(AnrListe.GetValue(j)), ";", , CompareMethod.Text)
```
in die einzelnen Werte zerlegen. Ich hab dann ein Array mit den jeweiligen Werten und kann sie superschnell weiterverarbeiten.

Die xml-Variante hat auch einen gewissen Reiz. Ich schau mir das mal an. Das Auslesen wird keine Probleme machen. Vielleicht ist der XML-Parser komfortabler.

joergINTERNET schrieb:
Hi Ihr zwei Profis,
[...]
Über welche Funktion von Erwins Code bekomme ich nun die Daten der Anrufliste in welchem Format zurück, damit ich diese der Tabelle hinzufügen kann?

Danke, VG Jörg

Wie bereits beschrieben bekommst du die Anrufliste als csv und als xml aus der Fritz!Box. Jetzt musst du die Datei deiner Wahl nur noch einlesen. XML-Parser oder wie beschrieben mittels Schleifen.

[Gelöst] Zugriff auf FB Anrufliste mit Microsoft Access

Neuer User

Aktives Mitglied

Neuer User

Aktives Mitglied

Anhänge

Neuer User

Neuer User

Aktives Mitglied

Neuer User

Aktives Mitglied

Neuer User

Aktives Mitglied

Anhänge

Neuer User

Aktives Mitglied

Aktives Mitglied

Anhänge

Neuer User

Neuer User

Neuer User

Aktives Mitglied

Neuer User

Aktives Mitglied

Statistik des Forums