Outlook Wählhilfe (Makro) ohne Box zu modifizieren

    ' Unterordner werden rekursiv durchsucht
    iOrdner = 1
    Do While iOrdner <= Ordner.Folders.Count And Not gefunden
        gefunden = FindeAbsender(Absender, KontaktID, Ordner.Folders.Item(iOrdner))
        iOrdner = iOrdner + 1
    Loop

Sub AnrMonRING_x()
    ' AnrMonRING(FBStatus As String, posRING As Long, anzeigen As Boolean)
    ' wertet einen eingehenden Anruf aus
    ' Parameter: FBStatus (String):   Status-String der FritzBox
    '            posRING (Long):      Position von RING im Status-String
    '            anzeigen (Boolean):  nur bei 'true' wird 'AnrMonEinblenden' ausgeführt
    
    Dim olNamespace As Outlook.NameSpace ' MAPI-Namespace
    Dim olFolder    As Outlook.MAPIFolder
    Dim TelNr       As String            ' ermittelte TelNr
    Dim Anrufer     As String            ' ermittelter Anrufer
    Dim vCard       As String            ' vCard des Anrufers
    Dim KontaktID   As String            ' ID der Kontaktdaten des Anrufers
    Dim LandesVW    As String            ' eigene Landesvorwahl
    Dim iIndx, jIndx, kIndx   As Integer
    Dim olFolderStoreID       As String        ' StoreId des Ordners
    
    LandesVW = "0049"
    TelNr = "0303410000099999"
    ' Daten zurücksetzen
    KontaktID = "-1;"
    Anrufer = ""
    
    ' Anrufer in den Outlook-Kontakten suchen
    Set olNamespace = CreateObject("Outlook.Application").GetNamespace("MAPI")
    ' laufe durch alle Ordner des Namespace
    For iIndx = 1 To olNamespace.Folders.Count
      ' laufe durch alle Items des/der Namespace-Ordner
      For jIndx = 1 To olNamespace.Folders.Item(iIndx).Folders.Count
        ' Setze Ordner-Variable
        Set olFolder = olNamespace.Folders.Item(iIndx).Folders.Item(jIndx)
        ' ist Ordner = Kontaktordner?
        If olFolder.DefaultItemType = olContactItem Then
          ' JA: dann...
          ' ...finde StoreID
          olFolderStoreID = olFolder.StoreID
          ' ...FindeAnrufer_x
          If FindeAnrufer_x(TelNr, LandesVW, KontaktID, olFolder, olFolderStoreID) Then
            With olNamespace.GetItemFromID(KontaktID, olFolderStoreID)
                Anrufer = Replace(.FullName & " (" & .CompanyName & ")", " ()", "")
                MsgBox Anrufer & Chr(13) & Chr(13) & olFolder.Name & Chr(13) & Chr(13) & olFolder.Parent.Name
            End With
          End If
        End If
      Next
    Next

    Set olNamespace = Nothing

End Sub

Private Function FindeAnrufer_x(TelNr As String, LandesVW As String, KontaktID As String, Ordner As Object, olFolderStoreID As String) As Boolean
    ' sucht in der Kontaktdatenbank nach der TelNr
    ' Parameter:  TelNr (String):      Telefonnummer des zu Suchenden
    '             LandesVW (String):   eigene Landesvorwahl
    '             KontaktID (String):  ID der Kontaktdaten falls was gefunden wurde (nur Rückgabewert)
    '             Ordner (Object):     der zu durchsuchende Kontaktordner (für die rekursive Suche)
    ' Rückgabewert (Boolean):          'true' wenn was gefunden wurde

    Dim iKontakt   As Long    ' Zählvariable für den aktuellen Kontakt
    Dim iOrdner    As Long    ' Zählvariable für den aktuellen Ordner
    Dim aktKontakt As Object  ' aktuelles Element
    Dim gefunden   As Boolean ' was gefunden?
    Dim alleTelNr  As Variant ' alle TelNr eines Kontakts
    Dim iTelNr     As Long    ' Zählvariable für die aktuelle TelNr
    Dim aktTelNr   As String  ' aktuelle TelNr
    
    gefunden = False
    iKontakt = 1
    Do While Not gefunden And iKontakt <= Ordner.Items.Count
        Set aktKontakt = Ordner.Items(iKontakt)
        With aktKontakt
            ' nur Kontakte werden durchsucht
            If .Class = olContact Then
                alleTelNr = Array(.AssistantTelephoneNumber, .BusinessTelephoneNumber, _
                    .Business2TelephoneNumber, .CallbackTelephoneNumber, .CarTelephoneNumber, _
                        .CompanyMainTelephoneNumber, .HomeTelephoneNumber, .Home2TelephoneNumber, _
                                .ISDNNumber, .MobileTelephoneNumber, .OtherTelephoneNumber, _
                                    .PagerNumber, .PrimaryTelephoneNumber, .RadioTelephoneNumber)
                iTelNr = LBound(alleTelNr)
                Do While Not gefunden And iTelNr <= UBound(alleTelNr)
                    If Not Len(alleTelNr(iTelNr)) = 0 Then
                        aktTelNr = nurZiffern(alleTelNr(iTelNr), LandesVW)
                        If TelNr = aktTelNr Then
                            gefunden = True
                            KontaktID = aktKontakt.EntryID
                            TelNr = alleTelNr(iTelNr)
                            olFolderStoreID = aktKontakt.Parent.StoreID
                        End If
                    End If
                    iTelNr = iTelNr + 1
                Loop
            End If
        End With
        DoEvents
        iKontakt = iKontakt + 1
    Loop
    ' Unterordner werden rekursiv durchsucht
    iOrdner = 1
    Do While iOrdner <= Ordner.Folders.Count And Not gefunden
        gefunden = FindeAnrufer_x(TelNr, LandesVW, KontaktID, Ordner.Folders.Item(iOrdner), Ordner.Folders.Item(iOrdner).StoreID)
        iOrdner = iOrdner + 1
    Loop
    FindeAnrufer_x = gefunden
    Set aktKontakt = Nothing
    'Set Ordner = Nothing ' ausgestellt für MsgBox
End Function

Function Wählbox(KontaktID As String, TelNr As String, StoreID As String)
...
        With CreateObject("Outlook.Application").GetNamespace("MAPI").GetItemFromID(KontaktID, StoreID)
....

Sub WählenAusKontakt()
    'Mit diesem Makro ist es möglich direkt aus einem geöffneten Kontakt oder Journaleintrag zu wählen. ähnlich wählboxstart

    Dim olAuswahl         As Inspector ' das aktuelle Inspector-Fenster (Kontakt oder Journal)
    Dim TelNr             As String    ' Telefonnummer des zu Suchenden
    Dim KontaktID         As String    ' KontaktID wird für Wählbox benötigt
    Dim vCard             As String
    Dim Name              As String
    Dim pos1              As Long
    Dim pos2              As Long
    Dim StoreID           As String
    
    Set olAuswahl = Application.ActiveInspector
    If Not olAuswahl Is Nothing Then
        With olAuswahl.CurrentItem
            If .Class = olContact Then  ' ist aktuelles Fenster ein Kontakt?
                Wählbox .EntryID, "", .Parent.StoreID
            ElseIf .Class = olJournal Then
                ' ist aktuelles Fenster ein Journal?
                If Not InStr(.Categories, "FritzBox Anrufmonitor") = 0 Then
                    ' wurde der Eintrag vom Anrufmonitor angelegt?
                    ' TelNr aus dem .Body entnehmen
                    TelNr = Mid(.Body, 11, InStr(1, .Body, vbNewLine) - 11)
                    If Not TelNr = "unbekannt" Then
                        If Not .Links.Count = 0 Then 'KontaktID des darangehangenen Kontaktes ermitteln
                            KontaktID = .Links.Item(1).Item.EntryID
                            StoreID = .Links.Item(1).Item.Parent.StoreID
                        Else
                            pos1 = InStr(1, .Body, "BEGIN:VCARD", vbTextCompare)
                            pos2 = InStr(1, .Body, "END:VCARD", vbTextCompare)
                            If Not pos1 = 0 And Not pos2 = 0 Then
                                pos2 = pos2 + 9
                                vCard = Mid(.Body, pos1, pos2 - pos1)
                                Name = Replace(ReadFromVCard(vCard, "N", ""), ";", "", , , vbTextCompare)
                                KontaktID = "-1" & Name & ";" & vCard
                            Else
                                KontaktID = "-1;"
                                StoreID = "-1;"
                            End If
                        End If
                        Wählbox KontaktID, TelNr, StoreID
                    End If
                End If
            End If
        End With
    End If
End Sub

    If Ordner.Class = olFolder Then
        If Ordner.DefaultItemType = olContactItem Then
            iKontakt = 1
            Do While Not gefunden And iKontakt <= Ordner.Items.Count
            [...]
            Loop
        End If
    End If

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

Option Explicit

'IP-Adressen ermitteln
Private Declare Function GetAdaptersInfo Lib "iphlpapi.dll" (pTcpTable As Any, pdwSize As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

Private Const MAX_ADAPTER_NAME_LENGTH         As Long = 256
Private Const MAX_ADAPTER_DESCRIPTION_LENGTH  As Long = 128
Private Const MAX_ADAPTER_ADDRESS_LENGTH      As Long = 8

Private Type IP_ADDRESS_STRING
    ipAddr(0 To 15)  As Byte
End Type

Private Type IP_MASK_STRING
    IpMask(0 To 15)  As Byte
End Type

Private Type IP_ADDR_STRING
    dwNext     As Long
    ipaddress  As IP_ADDRESS_STRING
    IpMask     As IP_MASK_STRING
    dwContext  As Long
End Type

Private Type IP_ADAPTER_INFO
  dwNext                As Long
  ComboIndex            As Long
  sAdapterName(0 To (MAX_ADAPTER_NAME_LENGTH + 3))        As Byte
  sDescription(0 To (MAX_ADAPTER_DESCRIPTION_LENGTH + 3)) As Byte
  dwAddressLength       As Long
  sIPAddress(0 To (MAX_ADAPTER_ADDRESS_LENGTH - 1))       As Byte
  dwIndex               As Long
  uType                 As Long
  uDhcpEnabled          As Long
  CurrentIpAddress      As Long
  IpAddressList         As IP_ADDR_STRING
  GatewayList           As IP_ADDR_STRING
  DhcpServer            As IP_ADDR_STRING
  bHaveWins             As Long
  PrimaryWinsServer     As IP_ADDR_STRING
  SecondaryWinsServer   As IP_ADDR_STRING
  LeaseObtained         As Long
  LeaseExpires          As Long
End Type



Private Function LocalIPAddresses() As String
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
   
Call 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 (ptr1 <> 0)
            'aktuellen Zeiger auf Datenstrucktur (Adapter) zuweisen
            CopyMemory Adapter, ByVal ptr1, LenB(Adapter)
            With Adapter
                'IP-Adresse des adapters auslesen
                sIPAddr = TrimNull(StrConv(.IpAddressList.ipaddress.ipAddr, vbUnicode))
                'und Name des Adapters durch das Ascii-Zeichen 1 getrennt, anfügen
                sAllAddr = sAllAddr & sIPAddr & Chr(1) & TrimNull(StrConv(.sDescription, vbUnicode)) & vbCrLf
                'Poiner auf nächsten Adapter setzen
                ptr1 = .dwNext
            End With
        Loop
    End If
End If

'letzes vbcrlf entfernen, wenn Adapter gefunden wurden
If Len(sAllAddr) > 0 Then sAllAddr = Left(sAllAddr, Len(sAllAddr) - 2)
'und Liste der Adapter mit ihren IP-Adressen ausgeben
LocalIPAddresses = sAllAddr
End Function


Private Function TrimNull(ByVal str As String) As String
On Error Resume Next

TrimNull = Trim(Left(str, InStr(str, Chr(0)) - 1))
End Function


Private Sub cmdRefresh_Click()
'IP-Adressen incl. Adapter ermitteln
'und das Ascii-Zeichen 1 durch das Trennzeichen " / " ersetzen
txtIPs.Text = Replace(LocalIPAddresses, Chr(1), " / ")
End Sub