Outlook Wählhilfe (Makro) ohne Box zu modifizieren

[McShark]

Noch eine Änderung in Function VersionsCheck(): Eine Abfrage ob der Text belegt ist. Das ist immer dann nicht der Fall, wenn die Webseite gerade nicht erreichbar ist und führt sonst immer zu einer Fehlermeldung bei der Zuweisung von neuVersion. Das habe ich schon ein paar mal beobachtet.

        If Text <> "" Then
            neuVersion = Left(Text, InStr(1, Text, ";", vbTextCompare) - 1)
            If aktVersion < neuVersion Then
                If MsgBox("Es gibt eine neue Version des Fritz!Box Telefon-dingsbums vom " & Mid(Text, InStr(1, Text, ";", vbTextCompare) + 1, 10) _
                & "." & vbNewLine & "Ihre Version: " & aktVersion & " -> neue Version: " & neuVersion & vbNewLine & _
                "Diese Datei(en) wurde(n) geändert: " & vbNewLine & Mid(Text, InStr(InStr(InStr(1, Text, ";", vbTextCompare) + 1, Text, ";", vbTextCompare) + 1, _
                Text, ";", vbTextCompare) + 1) & vbNewLine & vbNewLine & "Möchten Sie die neue Version jetzt herunterladen?", vbYesNo) = vbYes Then
                    formConfig.Herunterladen neuVersion
                End If
                LogFile "Neue Version gefunden: " & neuVersion
            End If
        End If

 

[Kruemelino]

Feststellung: [...]

Das ist ein allgemeines Problem und tritt immer dann auf wenn die Vorwahl die führende Null enthällt, also auch bei +xx 0yyyyy zzzzz - dd.
Man müsste irgendwie rausfiltern, ob eine Landesvorwahl vorgewählt wurde. Das ist aber nicht so einfach eine schöne Lösung zu finden.

Habe mir gerade überlegt, dass es sinnvoll wäre als Standardwert der FritzBox-Adresse keine IP sondern fritz.box einzugeben.
Testergebnis bei mir: Kommunikation funktioniert (über "Telefone erneut einlesen" getestet). Wenn ich aber Outlook neu starte bekomme ich folgende Fehlermeldung Hat jemand eine Idee woran das liegt?

Mal schauen. ist aber nicht sinnvoll.:spocht:

Ach ja, noch eine kleiner Verbesserungsvorschlag für formConfig in Private Sub ButtonTelefonliste_Click():[...]

Ich habe das eingefügt. Zusätzlich habe ich eine Funktion Meldung gebaut, die die ganzen MsgBox übernimmt. Das hat den Vorteil, dass alle Meldungen, wie Fehlermeldungen oder Hinweise gleich aussehen.

Noch eine Änderung in Function VersionsCheck(): [...]

Ich hatte sowieso vor den Versioncheck zu überarbeiten. Von daher wird sicherlich alles anders.

Neues Feature:
Ich hab mir überlegt, dass es vielleicht sinnvoll wäre die Anrufliste der Fritzbox mit zusätzlichen Daten zu füllen.
Wenn man die Datei heruntergeladen hat wird man gefragt ob man die zu den Telefonaten gehörigen Daten in den Kontakten (auch RWS) suchen will. Die Kontaktnamen werden dann neben der Liste eingefügt.
Leider dauert das recht lange, so dass ich einen Statusbalken gebastelt habe. So weit ich weiß gibt es im Outlook keine Möglichkeit einen Statusbalken einzublenden. (oder doch?)

Nun ja Kruemel

 

[McShark]

Mal schauen. ist aber nicht sinnvoll.:spocht:

Wieso nicht? Es wäre ja dann völlig egal wie die Adresse der Box lautet und würde auch bei nicht-Standard-einstellungen der Box quasi "OutOfThebox" funktionieren.

Leider dauert das recht lange, so dass ich einen Statusbalken gebastelt habe. So weit ich weiß gibt es im Outlook keine Möglichkeit einen Statusbalken einzublenden. (oder doch?)

Hast du sicherlich mit einem grünen Label gelöst, welches die Breite ändert, oder? Habe auf die Schnelle folgendes gefunden:

Dazu musst Du erstmal die Komponente "Microsoft Windows Common Control 5.0" oder "6.0" laden!
Dann hast Du in Deiner Werkzeugleiste nen paar neue Werkzeuge, u.a. die "Progress Bar"!
In der MSDN schaust Du dann mal unter "Fortschrittsleiste-Steuerelement (ProgressBar)"

 

[Kruemelino]

Ist natürlich die Frage ob man es verwenden darf.
Eine Progressbar ist patentrechtlich geschützt. Ich habe keine Ahnung worauf man sich dann einlässt.

 

[Novize]

Progressbars habe ich schon vor 20 Jahren bei Windows 286 / GEM / Apple und anderen Spielereien gesehen. Bei der Thomson-IP-TV-Box ist diese ebenso als Systemstartindikator zu sehen, wie beim Versand einer eMail von meinem Handy aus. Weiterhin sind diese in jeder mir bekannten Programmiersprache für jedes mir bekannte Betriebssystem vorhanden. (Nach 20 Jahren ist das Patent eh abgelaufen )
Wie will man das dann noch patentrechtlich schützen, wenn es doch Stand der Technik ist, von allen benutzt wird und damit kein Alleinstellungsmerkmal eines einzelnen darstellt?

 

[Kruemelino]

Du hast recht! Das sehe ich genauso

Ich habe bis nicht viel zu EP0394160 (Fortschritsbalken) erfahren. Es soll 2002 ausgelaufen sein. (wiki).
Sicherlich mach ich mir einen zugroßen Kopf. Aber lieber mal nachgelesen als hinterher dumm dastehen.
btw:
Adobe besitzt seit 2002 das Patent auf "Paletten mit Reitern". Das verwende ich in den Einstellungen.

 

[Novize]

Reiter sind doch nichts anderes als "Karteikarten". Dort Werkzeupaletten oder was auch immer zu platzieren, ist für mich nichts wirklich neues. Das mache ich schon länger, als ab 2002 so. Von daher beeindruckt mich auch dieses Patent nicht wirklich.
Da auch Adobe (z.B. beim Photoshop) dieses Verfahren schon wesentlich länger nutzt, ist das Patent imo eh hinfällig. Zumindest nach dt. Patentrecht.

 

[aNother]

2 Dinge von Interesse

Hallo @all, hallo Krümel
Die Makrosammlung ist zwar fast Perfekt, aber eine Sache wäre da noch: Da das Makro ja über die Weboberfläche arbeitet, könnte man doch nun auch nicht nur zu Hause das ganze benutzen.
AVM hat ja nun: Sichere Fernwartung mit Hilfe von HTTPS. So helfen sich Freunde

Mit der Fernwartung über HTTPS kann man einem Freund oder Helfer außerhalb des eigenen Netzes den Aufruf der FRITZ!Box-Benutzeroberfläche gestatten. Die Verbindung erfolgt über HTTPS und ist durch Benutzernamen und Kennwort gesichert.
eingebaut...
Wäre doch echt klasse das Makro per Dyndns auf der Arbeit laufen zu lassen...

Eine Kleinigkeit noch: die Kontaktbilder sind doch echt arg beschnitten und klein... kann ich das irgendwo anpassen? Ist das nur bei mir so (1024er Auflösung) ?

Have fun :groesste:

 

[Kruemelino]

:groesste:

:schleime:
Sowas ist sicherlich möglich, aber warum willst du das Makro von woanders verwenden?
Da ist auch wieder die Frage ob man von außen auf 1012 zugreifen kann. Die andere Frage ist wirklich wie nötig ist das? Das gleiche hab ich mich schon bei MultiBox gefragt.

Ich bin für viele Anregungen offen. Seid nicht böse, wenn ich mal keine Ahnung habe.

Mit den Kontaktbildern ist auch so ne sache. Beschnitten werden sie meines Erachtens nicht. Ich schau morgen nochmal nach und teste etwas.

Ich hab schon eine 238.zip hier rumliegen. Wie ich euch kenne wollt ihr die haben. Es gibt aber noch einige Kleinigkeiten, die ich gerne noch reinbringen will.
Ihr müsst noch etwas Geduld haben.

 

[McShark]

Das einzige, was auf Arbeit Sinn machen würde wäre die Anrufliste, und die kannst du auch so über den https-Zugang abrufen.

 

[Kruemelino]

mal bitte testen

 

[marcomarco]

Hallo Kruemlino,

ein erster Test hat bei mir keine Fehler zu Tage gefördert.
Kann es sein, dass seit einiger Zeit (also nicht erst seit dieser Version)
der Abruf der call-by-Call-daten nicht mehr funktioniert.
Ich bekomme immer einen "Laufzeitfehler 7" - Nicht genügend Speicher...
Oder haben die Webseitenbetreiber was geändert???
Oder leigt es am Ende doch an mir??
Ich habe:
Windows XP SP2
Outlook 2007
"nur" Benutzerrechte - keine lokalen Adminrechte

Gruß

MarcoMarco

 

[McShark]

Folgendes ist mir gegenüber der Vorversion aufgefallen:

• Bin etwas verunsichert (Siehe vorne, da steht aber auch die Version 2.33): welche Version der MSXML-Dienste soll denn nun mit dem Projekt verknüpft werden?
• an einigen Stellen sinnvolle Komentare hinzugefügt
• "Fritz!Box Dingsbums" an vielen Stellen gegen "Fritz!Box Script" ausgetauscht.
  Ist das ein neuer Name?
• Viele Kommentare gelöscht (formConfig), waren die sinnlos oder sind sie untergegangen?
• In formDirektwahl fehlt eine Änderung, die du im Forum so geschrieben hast:

  If Not Len(nurZiffern(Me.TelNrBox.Value, "")) = 0 Then

• Es ist gut, dass jetzt die Meldungen einheitlich aussehen und eine Überschrift haben. In dieser fehlt aber der Bezug zur Makrosammlung, schlage daher folgendes vor (übrigens ohne ! hinter Information):

  Function Meldung(ByVal Text As String, Typ As Long)
  ' Diese Funktion ist nur hinzugefügt worden, damit alle Fehlermeldungen gleich aussehen
      Dim Überschrift As String
      Überschrift = "Fritz!Box Dingsbums"
      Select Case Typ
      Case vbCritical
          Überschrift = Überschrift + " - Ein Fehler ist aufgetreten!"
      Case vbExclamation
          Überschrift = Überschrift + " - Achtung!"
      Case vbInformation
          Überschrift = Überschrift + " - Information"
      End Select
      MsgBox Text, Typ, Überschrift
  End Function

Kleine Textfehler:

• in nurZiffern: "Sonderzeichen wir Klammern", du meinst sicherlich "wie"
• in formConfig: "Das erneute Einlesen der Telefone ist hat keine Änderung ergeben.", da muss das ist raus

 

[Kruemelino]

Folgendes ist mir gegenüber der Vorversion aufgefallen:

Bin etwas verunsichert (Siehe vorne, da steht aber auch die Version 2.33): welche Version der MSXML-Dienste soll denn nun mit dem Projekt verknüpft werden?

Du kannst eigentlich alle verwenden. Den Fehler beim Herunterladen der Anrufliste nach Excel tritt auch bei mir unter XML5 auf.
Außerdem warum sollte XML6 nicht funktionieren? Damit hab ich ich alles programmiert.
Sicherlich kann marcomarco das ändern.

"Fritz!Box Dingsbums" an vielen Stellen gegen "Fritz!Box Script" ausgetauscht.
Ist das ein neuer Name?

Ne das war nur ein versehen. Ist geändert. Die einzige Funktion die noch "Fritz!Box Script" verwendet ist die Verschlüsselung der Config.

Viele Kommentare gelöscht (formConfig), waren die sinnlos oder sind sie untergegangen?

Hmm komisch. Wo sin die hin? WER HAT DIE VON EUCH GEKLAUT?
Verdammt keine ahnung wo die hin sind. musste sie alle per hand wieder reinkopieren.

In formDirektwahl fehlt eine Änderung, die du im Forum so geschrieben hast:

Ja die hab ich vergessen. Danke

Es ist gut, dass jetzt die Meldungen einheitlich aussehen und eine Überschrift haben. In dieser fehlt aber der Bezug zur Makrosammlung, schlage daher folgendes vor (übrigens ohne ! hinter Information):[/LIST]

ist drin.

Kleine Textfehler:

• 
  in nurZiffern: "Sonderzeichen wir Klammern", du meinst sicherlich "wie"

• 
  ja
  

  in formConfig: "Das erneute Einlesen der Telefone ist hat keine Änderung ergeben.", da muss das ist raus

  ja
  
  Die CbC Funktion teste ich im laufe des Tages.

 

[McShark]

Textverbesserung in Function FBLogin

' Da sich das Fritz!Box Dingsbums mehrfach in die Fritz!Box einloggt, wurde diese Funktion extrahiert.
' Um den 15-minütigen Timeout der Fritz!Box auszunutzen, loggt sich die Funktion alle 15 Minuten ein.
' Erzwingen - Wenn Wahr, dann wird ein Einloggen innerhalb der 15 Minuten erzwungen. Für einige Funktionen ist das sinnvoll.

Für das Problem, dass teilweise mit der Eingabe von fritz.box als Adresse Fehlermeldungen auftreten habe ich den Grund gefunden: Es wird teilweise mit dem Namen gearbeitet und Textfunktionen ausgeführt, da ist aber die IP-Adresse nötig, daher in Function LocalIPAddress:

' Ggf. die Adresse der Gegenstelle auflösen
If Ping(FB_ADD) = True Then
   FB_ADD = resolveIP(FB_ADD)
End If

und

Public Property Let RemoteHostIP(ByVal strRemoteIP As String)
    ' Ggf. die Adresse der Gegenstelle auflösen
    Dim TmpIPStr
    TmpIPStr = resolveIP(strRemoteIP)
    mstrRemoteHostIP = TmpIPStr
End Property

Eigentlich wollte ich die Namensauflösung in die Function Ping einbauen (auch weil dafür schon [momentan ungenutze] Funktionen dafür drin waren), habe es aber dann seingelassen die Funktion in eine Sub umzubauen (aus der Funktion kann ja nur ein Wert zurückkommen und ich habe noch den zweiten gebraucht). Falls jemand eine bessere Lösung hat kann man beides wieder zusammenführen. Hier sind sie:

Function Ping(IP As String) As Boolean
    ' Führt einen Ping aus, indem die DOS Pingroutine verwendet wird.
    ' http://www.microsoft.com/technet/scriptcenter/guide/sas_wsh_pkoy.mspx?mfr=true
    ' Wenn ein Ping nach 50 ms nicht beantwortet wurde, dann gilt er als verloren (Timeout -w 50)
    ' Wenn der Ping nicht erhalten wurde, dann wird Ping = False gesetzt. Das Makro startet nicht

    Dim objShell    As Object
    Dim objExec     As Object
    Dim objTextFile As Object
    Dim objFSO      As Object
    Dim objTempFile As String
    Dim objName     As String
    Dim strText     As String
    Dim Empfangen   As Long   ' Anzahl der empfangenen Pings
    Dim Anzahl      As Long   ' Anzahl aller Pings
    
    Ping = False
    Anzahl = 1 ' mit einem Ping geht es am schnellsten
    Empfangen = 0
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objShell = CreateObject("Wscript.Shell")
    objName = Environ("TEMP") & "\" & objFSO.GetTempName
    objTempFile = objName
    
    objShell.Run "cmd /c ping -n " & Anzahl & " -w 50 " & IP & " >" & objTempFile, 0, True
    Set objTextFile = objFSO.OpenTextFile(objTempFile, 1)
    Do While Not (objTextFile.AtEndOfStream = True Or Ping = True)
        strText = objTextFile.ReadLine
        If Len(strText) > 1 Then
            If Not InStr(strText, "Antwort") = 0 Then
                Empfangen = Empfangen + 1
                If Empfangen / Anzahl >= 0.75 Then Ping = True 'Falls mehrere Pings benötigt werden
            End If
        End If
    Loop
        
    objTextFile.Close
    objFSO.DeleteFile (objTempFile)
    
End Function '(Ping)

Function resolveIP(IP As String) As String
    ' Führt einen Ping aus, indem die DOS Pingroutine verwendet wird.
    ' http://www.microsoft.com/technet/scriptcenter/guide/sas_wsh_pkoy.mspx?mfr=true
    ' Gibt die aufgelöste IP zum Namen zurück

    Dim objShell    As Object
    Dim objExec     As Object
    Dim objTextFile As Object
    Dim objFSO      As Object
    Dim objTempFile As String
    Dim objName     As String
    Dim strText     As String
    Dim pos         As Long
    Dim pos2        As Long
    
    resolveIP = ""
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objShell = CreateObject("Wscript.Shell")
    objName = Environ("TEMP") & "\" & objFSO.GetTempName
    objTempFile = objName
    
    objShell.Run "cmd /c ping -n 1 -w 50 " & IP & " >" & objTempFile, 0, True
    Set objTextFile = objFSO.OpenTextFile(objTempFile, 1)
    Do While Not (objTextFile.AtEndOfStream = True Or Not resolveIP = "")
        strText = objTextFile.ReadLine
        If Len(strText) > 1 Then
            ' Nach der aufgelösten IP suchen
                pos = InStr(1, strText, IP & " [", vbTextCompare) + Len(IP & " [")
                pos2 = InStr(pos, strText, "]", vbTextCompare)
                If Not pos = Len(IP & " [") And Not pos2 = 0 Then
                    resolveIP = Mid(strText, pos, pos2 - pos)
                End If
        End If
    Loop
        
    objTextFile.Close
    objFSO.DeleteFile (objTempFile)
End Function '(resolveIP)

PS: wozu sind die Zeilen

IP = "fritz.box"
Ping IP

da? War damit die Funktion von resolveIP gemeint?

MfG
McShark

 

[Kruemelino]

Hallo zusammen,

Du hast mich mit deiner Idee auf die Lösung gebracht Viel einfacher, dazu später.

Die Funktion Ping führt einen Ping zur Fritz!Box aus und gibt die IP von fritz.box zurück. Sie lößt also den Namen auf und gibt den zurück. Sie kann also beliebig viele Werte zurückgeben.
zum Testen:

Sub test()
Dim IP As String
IP = "fritz.box"
Ping IP
MsgBox IP
End Sub

Allerdings gibt es einen Unterschied zwischen

Ping IP

und

Ping (IP)

Letzterer gibt "fritz.box zurück.

Textverbesserung [...]
PS: wozu sind die Zeilen

IP = "fritz.box"
Ping IP

da? War damit die Funktion von resolveIP gemeint?

Klar?

Die Lösung des Problemes:
Wir fügen einige "Ping"-aufrufe ein:

• LocalIPAddress
• AnrMonAnAus
• AnrMonStart

Function LocalIPAddress() As String
' Ermittelt die eigene IP Adresse
On Error Resume Next
'für API-Aufrufe
Dim cbRequired  As Long
Dim buff()      As Byte
Dim Adapter     As IP_ADAPTER_INFO
Dim AdapterStr  As IP_ADDR_STRING
'allgemeine Variablen
Dim ptr1        As Long
Dim sIPAddr     As String
Dim sAllAddr    As String
Dim sGWAddr     As String
Dim FB_ADD      As String
Dim pos         As Long
Dim DateiPfad As String
DateiPfad = GetSetting("FritzBox", "Optionen", "TBini", StandardPfad & "\Einstellungen.ini")
    
FB_ADD = GetINI(DateiPfad, "Optionen", "TBFBAdr", "192.168.178.1")
[COLOR="Red"]Ping FB_ADD[/COLOR]
pos = InStrRev(FB_ADD, ".", , vbTextCompare)
FB_ADD = Left(FB_ADD, pos)
GetAdaptersInfo ByVal 0&, cbRequired
If cbRequired > 0 Then
    ReDim buff(0 To cbRequired - 1) As Byte
    If GetAdaptersInfo(buff(0), cbRequired) = 0 Then
        'Zeiger (Pointer) zu den gespeicherten Daten (buff) ermitteln
        ptr1 = VarPtr(buff(0))
        'ptr1 ist 0 wenn keine weiteren Adapter vorhanden sind
        Do While Not ptr1 = 0
            'aktuellen Zeiger auf Datenstruktur (Adapter) zuweisen
            CopyMemory Adapter, ByVal ptr1, LenB(Adapter)
            With Adapter
                'IP-Adresse des Adapters auslesen
                sIPAddr = TrimNull(StrConv(.IpAddressList.ipaddress.ipAddr, vbUnicode))
                ' IP-Adresse des zugehörigen Gateways auslesen
                sGWAddr = TrimNull(StrConv(.GatewayList.ipaddress.ipAddr, vbUnicode))
                If Not InStr(1, sGWAddr, FB_ADD, vbTextCompare) = 0 _
                    Or Not InStr(1, sIPAddr, FB_ADD, vbTextCompare) = 0 Then
                        LocalIPAddress = sIPAddr
                End If
                'Poiner auf nächsten Adapter setzen
                ptr1 = .dwNext
            End With
        Loop
    End If
End If

End Function

Private Sub AnrMonAnAus()
    ' wird durch das Symbol 'Anrufmonitor' in der 'FritzBox'-Symbolleiste ausgeführt
    ' schaltet den Anrufmonitor an bzw. aus
    
    Dim cmb       As CommandBar         ' FritzBox-Symbolleiste
    Dim TimerID   As Long               ' Kennung des verwendeten Timers
    Dim FBAdresse As String             ' IP der FritzBox
    Dim formdata  As String             ' an die FritzBox übermittelte Web-Daten (für Anmeldung)
    Dim ID        As Integer
    
    Set cmb = Application.ActiveExplorer.CommandBars.Item("FritzBox")
    TimerID = CLng(GetSetting("FritzBox", "Timer", "IDAnrMon", -1))
    If Not TimerID = -1 Then
        ' Timer stoppen, TCP/IP-Verbindung schließen
        KillTimer 0, TimerID
        SaveSetting "FritzBox", "Timer", "IDAnrMon", "-1"
        LogFile "TimerID " & str(TimerID) & " - gestoppt (AnrMon-Timer)"
        tcp.ShutdownConnection
        ' 'formAnrMon' ausblenden und Symbol 'Anrufmonitor' als nicht gedrückt markieren
        On Error Resume Next     ' Fehlerbehandlung ausschalten
        formAnrMon.Hide
        Stop_MP3 "FBDB"
        On Error GoTo 0          ' Fehlerbehandlung einschalten
        cmb.FindControl(, , "Anrufmonitor").State = msoButtonUp
        aktiv = False
    Else
        ' TCP/IP-Verbindung öffnen
        KeyÄnderung
        FBAdresse = GetINI(DateiPfad, "Optionen", "TBFBAdr", "192.168.178.1")
        If [COLOR="Red"]Ping(FBAdresse)[/COLOR] Then
            For ID = 0 To 9
                If GetINI(DateiPfad, "Journal", "RINGCALL" & str(ID), False) Then
                    WriteINI DateiPfad, "Journal", "RINGCALL " & ID, False
                End If
            Next
            tcpTimeout = GetINI(DateiPfad, "Optionen", "TBTimeOut", "250")
            tcp.LocalHostIP = LocalIPAddress()
            tcp.RemoteHostIP = FBAdresse
            tcp.RemotePort = 1012
            If Not tcp.OpenConnection Then
                Meldung "Es ist ein TCP/IP Fehler aufgetreten:" & vbNewLine & tcp.ErrorDescription, vbCritical
                Exit Sub
            End If
            ' Timer starten und Symbol 'Anrufmonitor' als gedrückt markieren
            cmb.FindControl(, , "Anrufmonitor").State = msoButtonDown
            aktInterv = 0
            TimerID = SetTimer(0, 0, GetINI(DateiPfad, "Optionen", "TBIntervall", "2000"), AddressOf AnrMonAktion)
            ' 'TimerID' in Registry speichern
            SaveSetting "FritzBox", "Timer", "IDAnrMon", CStr(TimerID)
            LogFile "TimerID " & str(TimerID) & " - gestartet (AnrMon-Timer)"
            If GetINI(DateiPfad, "Optionen", "CBJournal", False) Then
                If GetINI(DateiPfad, "Optionen", "CBJImport", False) Then
                    WriteINI DateiPfad, "Journal", "StartJI", CDate(GetINI(DateiPfad, "Journal", "SchließZeit", Date + Time))
                    WriteINI DateiPfad, "Journal", "EndeJI", Date + Time
                    DownloadAnrListe
                End If
            End If
            aktiv = False
        Else
            LogFile "Keine Fritz!Box gefunden."
            Meldung "Es wurde keine Fritz!Box gefunden.", vbCritical
        End If
    End If
    Set cmb = Nothing
End Sub '(AnrMonAnAus)

Function AnrMonStart()
    ' wird beim Start von Outlook ausgeführt und startet den Anrufmonitor
    
    Dim cmb       As CommandBar         ' FritzBox-Symbolleiste
    Dim TimerID   As Long               ' Kennung des verwendeten Timers
    Dim FBAdresse As String             ' IP der FritzBox
    Dim formdata  As String             ' an die FritzBox übermittelte Web-Daten (für Anmeldung)
    Dim ID        As Integer
    
    For ID = 0 To 9
        If GetINI(DateiPfad, "Journal", "RINGCALL" & str(ID), False) Then
            WriteINI DateiPfad, "Journal", "RINGCALL " & ID, False
        End If
    Next
    ' eventuell laufenden Timer stoppen
    TimerID = CLng(GetSetting("FritzBox", "Timer", "IDAnrMon", -1))
    If Not TimerID = -1 Then
        KillTimer 0, TimerID
        SaveSetting "FritzBox", "Timer", "IDAnrMon", -1
        LogFile "TimerID " & str(TimerID) & " - gestoppt (AnrMon-Timer)"
        formAnrMon.Hide
        Stop_MP3 "FBDB"
    End If
    FBAdresse = GetINI(DateiPfad, "Optionen", "TBFBAdr", "192.168.178.1")
    If GetINI(DateiPfad, "Optionen", "CBAnrMonAuto", False) Then
        If [COLOR="Red"]Ping(FBAdresse)[/COLOR] Then
            If Not Application.Explorers.Count = 0 Then
                Set cmb = Application.ActiveExplorer.CommandBars("FritzBox")
                tcpTimeout = GetINI(DateiPfad, "Optionen", "TBTimeOut", "250")
                tcp.LocalHostIP = LocalIPAddress()
                tcp.RemoteHostIP = FBAdresse
                tcp.RemotePort = 1012
                ' TCP/IP-Verbindung öffnen
                If Not tcp.OpenConnection Then
                    Meldung "Es ist ein TCP/IP Fehler aufgetreten:" & vbNewLine & tcp.ErrorDescription, vbCritical
                    Exit Function
                End If
                ' Timer starten
                cmb.FindControl(, , "Anrufmonitor").State = msoButtonDown
                aktInterv = 0
                TimerID = SetTimer(0, 0, GetINI(DateiPfad, "Optionen", "TBIntervall", "2000"), AddressOf AnrMonAktion)
                SaveSetting "FritzBox", "Timer", "IDAnrMon", CStr(TimerID)
                LogFile "TimerID " & str(TimerID) & " - gestartet (AnrMon-Timer)"
                If GetINI(DateiPfad, "Optionen", "CBJournal", False) Then
                    If GetINI(DateiPfad, "Optionen", "CBJImport", False) Then
                        WriteINI DateiPfad, "Journal", "StartJI", CStr(GetINI(DateiPfad, "Journal", "SchließZeit", Date + Time))
                        WriteINI DateiPfad, "Journal", "EndeJI", Date + Time
                        DownloadAnrListe
                    End If
                End If
                aktiv = False
                Set cmb = Nothing
            End If
        Else
            LogFile "Keine Fritz!Box gefunden."
            Meldung "Es wurde keine Fritz!Box gefunden.", vbCritical
        End If
    End If
End Function '(AnrMonStart)

Ich denke das müsste reichen. Bei mir geht es

 

[McShark]

Das ist genau das, was ich wollte. Die Anpassungen der Ping Funktion macht aber trotzdem Sinn, hier ist die zu erst erstellte Version, die ich wieder verworfen habe, weil der Unterschied zwischen "Funktion Wert" = Ausführen und Änderungen an Wert übernehmen und "Funktion (Wert)" = Ausführen und den Rückgabewert nutzen sowie Wert übernehmen" nicht klar war.
Habe ich es jetzt richtig verstanden?
Der

Function Ping(IP As String) As Boolean
    ' Führt einen Ping aus, indem die DOS Pingroutine verwendet wird.
    ' http://www.microsoft.com/technet/scriptcenter/guide/sas_wsh_pkoy.mspx?mfr=true
    ' Wenn ein Ping nach 50 ms nicht beantwortet wurde, dann gilt er als verloren (Timeout -w 50)
    ' Wenn der Ping nicht erhalten wurde, dann wird Ping = False gesetzt. Das Makro startet nicht.
    ' Modifiziert den Parameter IP: Wenn möglich die aufgelöste IP zum Namen übergeben.

    Dim objShell    As Object
    Dim objExec     As Object
    Dim objTextFile As Object
    Dim objFSO      As Object
    Dim objTempFile As String
    Dim objName     As String
    Dim strText     As String
    Dim Empfangen   As Long    ' Anzahl der empfangenen Pings
    Dim Anzahl      As Long    ' Anzahl aller Pings
    
    Dim IP_resolved As Boolean ' Ist die IP aufgelöst?
    Dim pos, pos2   As Long    ' Zählervariablen für auflösung IP-Adresse
    
    Ping = False
    IP_resolved = False
    Anzahl = 1 ' mit einem Ping geht es am schnellsten
    Empfangen = 0
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objShell = CreateObject("Wscript.Shell")
    objName = Environ("TEMP") & "\" & objFSO.GetTempName
    objTempFile = objName
    
    objShell.Run "cmd /c ping -n " & Anzahl & " -w 50 " & IP & " >" & objTempFile, 0, True
    Set objTextFile = objFSO.OpenTextFile(objTempFile, 1)
    Do While Not (objTextFile.AtEndOfStream = True Or Ping = True)
        strText = objTextFile.ReadLine
        If Len(strText) > 1 Then
            If IP_resolved = False Then
            ' Nach der aufgelösten IP suchen
                pos = InStr(1, strText, IP & " [", vbTextCompare) + Len(IP & " [")
                pos2 = InStr(pos, strText, "]", vbTextCompare)
                If Not pos = Len(IP & " [") And Not pos2 = 0 Then
                    IP = Mid(strText, pos, pos2 - pos)
                    IP_resolved = True
                End If
            Else
                If Not InStr(strText, "Antwort") = 0 Then
                    Empfangen = Empfangen + 1
                    If Empfangen / Anzahl >= 0.75 Then Ping = True ' Falls mehrere Pings benötigt werden
                End If
            End If
        End If
    Loop
        
    objTextFile.Close
    objFSO.DeleteFile (objTempFile)
    
End Function '(Ping)

PS: was macht SF?

 

[Kruemelino]

Warum die Funktion nicht gleich neuschreiben:

Function Ping(IP As String) As Boolean
    ' Führt einen Ping aus, indem die DOS Pingroutine verwendet wird.
    ' Wenn ein Ping nach 50 ms nicht beantwortet wurde, dann gilt er als verloren (Timeout -w 50)
    ' Wenn der Ping nicht erhalten wurde, dann wird Ping = False gesetzt. Das Makro startet nicht

    
    Dim TempDatei   As String
    Dim pos1        As Long
    Dim pos2        As Long
    Dim Text        As String
    
    Ping = False

    TempDatei = Environ("TEMP") & "\temp.tmp"
    
    CreateObject("Wscript.Shell").Run "cmd /c ping -n 1 -w 50 " & IP & " >" & TempDatei, 0, True
    
    Text = HTTPTransfer("GET", TempDatei)
    If Not InStr(1, Text, "Antwort", vbTextCompare) = 0 Then
        pos1 = InStr(1, Text, "[", vbTextCompare) + 1
        pos2 = InStr(pos1, Text, "]", vbTextCompare)
        
        If Not pos1 = 1 And Not pos2 = 0 Then
            IP = Mid(Text, pos1, pos2 - pos1)
        End If
            
        Ping = True
    End If
End Function '(Ping)

Edith: Hab es nochmal geändert

 

[McShark]

Scheint gut zu klappen und sieht auch besser aus. Für's neuschreiben fehlen mir noch Einblicke in VBA.

 

[Kruemelino]

Mal ne Frage:
die Passwörter werden verschlüsselt. Ich habe den Entschlüsselungsshchlüssel aus der ini-Datei in die Registry verschoben.
Das führt aber dazu, dass die Entschlüsselung nicht mehr funktioniert. Man muss einmalig das Passwort neu eingeben.
Spricht da was dagegen?