AW: Listbox mit Bedingungen befüllen
16.06.2016 18:54:42
Beverly
Hi René,
mit dieser Codezeile
If Mid(.CompanyName, 1, Len(TextBox1.Value)) = TextBox1.Value Then
werden nur die Teile am Beginn angesprochen. Wenn du generell nach einer Buchstabenkombination suchen willst, musst man Instr verwenden (ist enthalten).
Es muss also unterschieden werden, ob ein Firmenname vorhanden ist oder nicht, aber auf eine etwas andere Weise, denn der Code würde ja nur in den If-Zweig gehen, wenn der TextBox-Inhalt im Firmennamen enthalten ist. Man muss also zuerst prüfen, ob der Firmenname vorhanden ist, und wenn ja, danach ob der TextBox-Inhalt im Firmennamen enthalten. Ist kein Firmenname vorhanden, dann muss geschaut werden, ob der TextBox-Inhalt im Vornamen oder im Nachnamen enthalten ist.
Der Code muss aber noch etwas abgewandelt werden: den Zähler MyOutID kann nicht verwendet werden, da dieser ja davon ausging, dass alle Einträge übernommen werden. Jetzt sind es aber nur ausgewählte und stattdessen bezieht man sich auf die Anzahl an bereits vorhandenen Einträgen in der ListBox (ListBox.ListCount).
Damit der Code für das Eintragen der 2. bis 6. Spalte nicht doppelt geschrieben werden muss (jeweils für den Teil Firmenname und den Teil für Vor-/Nachname), kann man das mit einer Boolschen Variablen etwas "abkürzen" und diese Spalten nur füllen wenn tatsächlich ein neuer Eintrag gemacht wurde.
Private Sub CommandButton1_Click()
'(C) by Ramses
'Verweis auf die Outlook Library muss gesetzt sein
'Variablen Deklaration
Dim MyOutId As Integer
Dim MyOutFolder As Object
Dim MyOutApp As Object
Dim MyConItem As Object
Dim Qe As Integer
Dim ErrMsg As String
Dim blnEintragen As Boolean
'Bildschirmaktualisierung ausschalten
'Application.DisplayAlerts = False
'... und Statusbar-Info ausgeben
Application.StatusBar = " die Adressen werden aus Outlook geholt " _
& " - das kann einen Moment dauern."
'Object Deklaration
Set MyOutApp = CreateObject("Outlook.Application")
'Zugriff auf die MAPI Schnittstelle
Set MyOutFolder = MyOutApp.GetNamespace("MAPI").GetDefaultFolder(10)
'Zuweisen der Anzahl Spalten in der Listbox
Me.ListBox1.ColumnCount = 6
'Zuweisen der Spaltenbreite in Pt
'1 cm ~ 28,3 Pt
Me.ListBox1.ColumnWidths = "200;100;80;80;80;100"
Me.ListBox1.Clear
'Einlesen der Daten
For MyOutId = 1 To MyOutFolder.Items.Count
'Zuweisen des Object für jeden Contact
Set MyConItem = MyOutFolder.Items(MyOutId)
'Einlesen des Contacts beginnen
With MyConItem
'On Error GoTo conError
' Firmenname ist vorhanden
If .CompanyName "" Then
' TextBox-Inhalt ist im Firmennamen enthalten
If InStr(.CompanyName, TextBox1.Value) > 0 Then
'Neuen Eintrag in Listbox einfügen
Me.ListBox1.AddItem " "
'ListIndex - 1 um auf das vorher erzeugte Item zuzugreifen
Me.ListBox1.List(Me.ListBox1.ListCount - 1, 0) = .CompanyName
blnEintragen = True
End If
Else
' TextBox-Inhalt ist im Vornamen oder Nachnamen enthalten
If InStr(.FirstName, TextBox1.Value) > 0 Or InStr(.LastName, TextBox1.Value) > _
0 Then
'Neuen Eintrag in Listbox einfügen
Me.ListBox1.AddItem " "
Me.ListBox1.List(Me.ListBox1.ListCount - 1, 0) = .FirstName & " " & . _
LastName
blnEintragen = True
End If
End If
' es wurde ein Eintrag in die ListBox vorgenommen, dann restliche Daten eintragen
If blnEintragen Then
Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = .BusinessAddressPostalCode & " _
" & . _
BusinessAddressCity
Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) = .BusinessAddressStreet
Me.ListBox1.List(Me.ListBox1.ListCount - 1, 3) = .BusinessTelephoneNumber
Me.ListBox1.List(Me.ListBox1.ListCount - 1, 4) = .BusinessFaxNumber
Me.ListBox1.List(Me.ListBox1.ListCount - 1, 5) = .MobileTelephoneNumber
Me.ListBox1.List(Me.ListBox1.ListCount - 1, 6) = .Email1Address
End If
' Variable wieder in den Ausgangszustand für nächsten Schleifendurchlauf
blnEintragen = False
'Statusbar Information anzeigen
'um den Benutzer den Fortschritt anzuzeigen
Application.StatusBar = "Datensatz " & MyOutId & " von " & MyOutFolder.Items.Count & _
_
" wird gelesen: " & .FirstName
ErrorStepin:
End With
Next MyOutId
ErrorExit:
'Object Variablen leeren
Set MyConItem = Nothing
Set MyOutFolder = Nothing
Set MyOutApp = Nothing
'Bildschirm einschalten
Application.DisplayAlerts = True
'Statusbar zurücksetzen
Application.StatusBar = False
Exit Sub
conError:
Select Case Err
Case 438
'Es kann sein, dass ein Datensatz korrupt ist, aber in Outlook korrekt angezeigt _
wird
'Allerdings können diese Datensätze nicht mit externen Geräte synchronisiert werden
Set MyConItem = MyOutFolder.Items(MyOutId)
ErrMsg = "Datensatz " & MyOutId & " ist korrupt, oder unterstützt die Abfrage nicht. _
ErrMsg = ErrMsg & vbCrLf & "Datensatzkennung:"
ErrMsg = ErrMsg & vbCrLf & "Erstelldatum: " & MyConItem.CreationTime
ErrMsg = ErrMsg & vbCrLf & "ObjectID" & MyConItem.EntryID
ErrMsg = ErrMsg & vbCrLf
ErrMsg = ErrMsg & vbCrLf & "Löschen ? "
Qe = MsgBox(ErrMsg, vbYesNo + vbCritical + vbDefaultButton2, "Datenfehler")
If Qe = vbYes Then
MyConItem.Delete
MsgBox ("Datensatz " & MyOutId & " wurde gelöscht")
'Listenzählung korrigieren
MyOutId = MyOutId + 1
Me.ListBox1.ListIndex(MyOutId).Delete
Resume ErrorStepin
Else
MsgBox "Datenimport wegen Datenfehler bei Datensatz " & MyOutId & " abgebrochen" _
Resume ErrorExit
End If
Case Else
MsgBox Err & ": " & Err.Description
Resume ErrorExit
End Select
End Sub