x-herbert schrieb:DIRTY HACKING!!!
Thema ist immer noch "Suche alle Kontakte"
Vorweg. ich habe drei "Hauptordner" mit jeweils mehreren Kontakte-Ordnern
mein Testscript:
PHP:Sub mytest() Dim outApp As Outlook.Application Dim outNms As Outlook.NameSpace Dim aktKontakt As Object ' aktuelles Element Dim iIndx, jIndx, kIndx As Integer Dim sAdLName As String Dim sFdrMName As String ' Haupt-ordner-Name Dim alleTelNr As Variant ' alle TelNr eines Kontakts Dim outFdr As MAPIFolder Dim outCon As Object Set outApp = New Outlook.Application Set outNms = outApp.GetNamespace("MAPI") For iIndx = 1 To outNms.Folders.Count sFdrMName = outNms.Folders.Item(iIndx).Name For jIndx = 1 To outNms.Folders.Item(iIndx).Folders.Count Set outFdr = outNms.Folders.Item(iIndx).Folders.Item(jIndx) If outFdr.DefaultItemType = olContactItem Then For kIndx = 1 To outNms.Folders.Item(iIndx).Folders.Item(jIndx).Items.Count Set outCon = outNms.Folders.Item(iIndx).Folders.Item(jIndx).Items.Item(kIndx) With outCon ' nur Kontakte werden durchsucht If .Class = olContact Then alleTelNr = Array(.AssistantTelephoneNumber, .BusinessTelephoneNumber, _ .Business2TelephoneNumber, .CallbackTelephoneNumber, .CarTelephoneNumber, _ .CompanyMainTelephoneNumber, .HomeTelephoneNumber, .Home2TelephoneNumber, _ .ISDNNumber, .MobileTelephoneNumber, .OtherTelephoneNumber, _ .PagerNumber, .PrimaryTelephoneNumber, .RadioTelephoneNumber) End If End With Next End If Next Next Set outFdr = outNms.GetDefaultFolder(olFolderContacts) For iIndx = 1 To outFdr.Items.Count Set outCon = outNms.GetDefaultFolder(olFolderContacts).Items(iIndx) With outCon ' nur Kontakte werden durchsucht If .Class = olContact Then alleTelNr = Array(.AssistantTelephoneNumber, .BusinessTelephoneNumber, _ .Business2TelephoneNumber, .CallbackTelephoneNumber, .CarTelephoneNumber, _ .CompanyMainTelephoneNumber, .HomeTelephoneNumber, .Home2TelephoneNumber, _ .ISDNNumber, .MobileTelephoneNumber, .OtherTelephoneNumber, _ .PagerNumber, .PrimaryTelephoneNumber, .RadioTelephoneNumber) End If End With Next End Sub
Im "ersten" Teil finde ich alle meine Kontakte mit entsprechenden Telefonnummern - leider keine Unterordner...
Wenn man das "outNms" ausgeben lässt, sind alle Elemente gut zu "sehen"
Ich habe mal den Code aus "FindeAbsender" übernommen um zu testen, ob hier auch die Unterordner gefunden werden (habe in dem Default-Kontakte ein Unterodner angelegt) - die werden aber bei der "zweiten" Schleife nicht aufgelistet???
[dass die Schleifen auch mit "each" usw. gehen is schon klaro... hier gehts ums Prinzip!]
Würde gern mal die Meinung der Fachmänner hören/lesen...
Gruss x-herbert
' 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
LoopSub 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 FunctionFunction 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 Subdscampari schrieb:Ich benutze WinXP mit Office 2003. Die Box ist eine ATA mit der letzten (älteren) Firmware. Eine ältere Version des Tools hatte auch schon mal funktioniert.
Die StoreID können wir die nicht verwenden, weil es die erst ab OL07 gibt...
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 IfIf 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 IfOption 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
