Kontaktimport Excel nach Outlook inkl. benutzerdefinierter Felder (VB6 Code)

Vb6-Code für den Import von Kontaktdaten aus einer Exceldatei nach Outlook inklusive benutzerdefinierter Felder

Hallo,

hab mir schon diverse Import und Export Tools für unsere Kontaktdatenbank gebastelt, da bei der in Outlook integrierten Lösung keine benutzerdefinierten Felder übernommen werden.
Dabei hab ich mir nun ein Addin für Outlook geschrieben, welches diese Aufgabe übernimmt.

Das Formular besteht aus einem Button, einem CommonDialog und einer Listbox.

Die erste Zeile in der Exceldatei enthält dabei die Feldnamen für die Outlookdatenbank (Diese müssen exakt passen).

Private Sub Command1_Click()
  On Error GoTo ErrHandler
Dim vFiles As Variant
Dim lFile As Long

With CommonDialog1
    .FileName = ""   
    .CancelError = True
    .DialogTitle = "Select File"  
    .Filter = "Excel-Datei (*.xls)|*.xls;"  
    .ShowOpen
    vFiles = Split(.FileName, Chr(0))
    If UBound(vFiles) <> 0 Then
       MsgBox ("Nur eine Datei auswählen")  
      Goto Ende 
End If
End With

Dim Excel As Object
Set Excel = CreateObject("Excel.Application")  
Excel.Visible = True
Excel.Workbooks.Open CommonDialog1.FileName

Dim x As Integer
Dim Y As Integer
x = Excel.worksheets.Item(1).usedrange.Columns.Count
Y = Excel.worksheets.Item(1).usedrange.Rows.Count

Dim i As Integer
Dim j As Integer

Dim aOutlook As Object
Dim Contacts As Object
Dim Contact As Object
Dim Filter As String
Dim DubContact As Object
'Set aOutlook = Application   
set aOutlook = CreateObject("Outlook.Application")  
Set Contacts = aOutlook.GetNameSpace("MAPI").Folders.Item("Öffentliche Ordner").Folders("Alle öffentlichen Ordner").Folders("Kontakte von Test")  
For j = 2 To Y    'Jede Zeile in der Excelliste lesen  
  List1.Clear
  List1.AddItem ("Index: " + CStr(j))  
  Set Contact = Contacts.Items.Add
  For i = 1 To x  'Alle Eigenschaften in der Liste  
    Contact.itemProperties.Item(Excel.cells(1, i).Value).Value = Excel.cells(j, i).Value
    List1.AddItem ("Schreibe " + Excel.cells(1, i).Value)  
  Next i
  Filter = "[LastName] = '" + Contact.LastName + "' AND [BusinessAddressPostalCode] = '" + Contact.BusinessAddressPostalCode + "' AND [BusinessAddressStreet] = '" + Contact.BusinessAddressStreet + "' AND [CompanyName]= '" + Contact.CompanyName + "'"  
  Set DubContact = Contacts.Items.Find(Filter)
  If DubContact Is Nothing Then
    List1.AddItem ("Kontakt nicht doppelt")  
    List1.AddItem ("Kontakt gespeichert")  
    Contact.Save
  Else
    List1.AddItem ("***Kontakt doppelt***")  
  End If
  Set Contact = Nothing
Next j

Exit Sub
ErrHandler:
If Err <> cdlCancel Then
    MsgBox Err.Description
End If
Ende:
End Sub

Mfg
Benny

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 112138

Url: https://administrator.de/contentid/112138

Ausgedruckt am: 21.11.2024 um 14:11 Uhr

12 Kommentare

Neuester Kommentar

Hallo Benny,

danke für die Anleitung bzw. eher das Skript.

Ich werde sie die Tage austesten. Meine Frage dazu: Welche Outlook-Version bedient sie (2003/2007) bzw. ist das für beide?

Viele Grüße
Jörg

PS: Vielleicht hast Du nen konzeptionellen Tipp für mich, wie man aus Outlook 2003 Adressen herausbekommt (im Sinne von Drag&Drop von Outlook nach Excel, ggf. auch per Export), wo die Postanschrift (Häcken gesetzt "Ist die Postanschrift") nicht in _einem_ Feld exportiert wird. Im Prinzip müsste es wohl ein Skript (?) sein, das abprüft, welche der beiden Adressen (Geschäftlich/Privat) die Postanschrift ist und dann alle Felder von AdressePrivat ODER AdresseGeschäftlich exportiert (Straße, PLZ, Ort).

Hallo Jörg,

ich benutz es unter 2003. Da jedoch lediglich das Outlook und Excel Object verwendet worden ist, sehe ich eigentlich keinen Grund, warum es unter 2007 nicht laufen sollte (habs aber nie getestet).

Willst du alle Kontakte exportieren oder nur die, die in dem Ordner ausgewählt wurden? An deiner Stelle würde ich mir nen VBA-Script machen und dann einen neuen Button in Outlook integieren, welcher das Makro startet.

Als VBA-Code würde das gehen:

Public Sub Export()
Dim Excel
Set Excel = CreateObject("Excel.Application")  
Excel.Visible = True
Excel.Workbooks.Add

Dim Y

Dim aOutlook
Dim Contacts
Dim Contact
Dim Counter
Set aOutlook = Application
Set Contacts = aOutlook.ActiveExplorer.Selection
counter = Contacts.Count

for i =1 to Counter
  set Contact = Contacts.Item(i)
  Y = Excel.worksheets.Item(1).usedrange.Rows.Count
  Excel.cells(y,1).value=Contact.MaillingAddressStreet
  Excel.cells(y,2).value=Contact.MailingAddressPostalCode
  Excel.cells(y,3).value=Contact.MailingAddressCity
  set Contact = Nothing
next i

set Contacts = Nothing
set aOutlook = Nothing
set Excel = Nothing

End Sub

Mfg
Benny

Hi Benny.

man, bist Du schnell!

Wir haben hier auch nur Outlook 2003, das ist auch völlig ok für uns.

Hinsichtlich meines Export-Problems:

Ich hab das natürlich gleich ausprobiert, allerdings hängts an Zeile 20: Fehlermeldung Laufzeitfehler 438. Objekt unterstützt diese Eigenschaft oder Methode nicht.

BREAK: war nen _l_ zuviel bei Mailling

Jau, geht! Die als Postanschrift markierte Adresse wird separiert nach Straße, PLZ, Ort in eine neue Excel-Tabelle ausgegeben. Klasse!

Allerdings nur genau eine Adresse (da, wo in Outlook der Cursor drin steht (aktiv ist in der Telefonlistenansicht).

Mehrere Zeilen markieren hat leider nicht geholfen. (vermute, dass die Selektion in Zeile 14 abgefragt wird?)

Kannst Du noch mal bitte gucken, was da das Problem ist?

Wo kann ich nachschauen, wie die Outlook-Felder für Anrede, Vorname, Name, Firma und Telex laueten? (nicht wundern. Im Feld Telex steht bei uns die Anzahl von zu liefernden Publikationen

)

Herzlichen Dank
Jörg

Ja ja, waren ein paar Fehlerchen drin...

(so gehts)

Public Sub Export()
Dim Excel
Set Excel = CreateObject("Excel.Application")  
Excel.Visible = True
Excel.Workbooks.Add

Dim Y

Dim aOutlook
Dim Contacts
Dim Contact
Dim Counter
Set aOutlook = Application
Set Contacts = aOutlook.ActiveExplorer.Selection
counter = Contacts.Count

for i =1 to Counter
  set Contact = Contacts.Item(i)
  Y = Excel.worksheets.Item(1).usedrange.Rows.Count + 1
  Excel.cells(y,1).value=Contact.MailingAddressStreet
  Excel.cells(y,2).value=Contact.MailingAddressPostalCode
  Excel.cells(y,3).value=Contact.MailingAddressCity
  set Contact = Nothing
next i

set Contacts = Nothing
set aOutlook = Nothing
set Excel = Nothing

End Sub

Zeile 19 und 20 korrigiert....

Feldernamen geh mal in Outlook "Extras->Makro->VB-Script-Editor" in VB-Editor dann "Ansicht->Objectkatalog" da findeste dann alle Methoden Eigenschaften etc. fürs "ContactItem"

Mfg
Benny

was du suchst ist:
Titel
Firstname
Lastname
CompanyName
BusinessFaxNumber

Hallo Benny,

ich hab das Skript probiert. An sich läuft es, jedoch gibt es noch eine kleine ""Macke"".

Die Variable Y bleibt immer auf 2, sie zählt offensichtlich in Zeile 19 nicht hoch.

Die Folge ist, dass ich beim Starten des Skriptes sehe, wie in der Excel-Tabelle in Zeile 2 alle im Outlook markieten Namensdatensätze ""durchrauschen"" (sieht cool aus

) und am Ende nur der letzte Datensatz in Zeile steht.

Könntest Du da bitte mal schauen? Ich krieg das nicht hin, habs probiert.

Ich muss mich mal mit den enormen Möglichkeiten von VB6 beschäftigen, wenn ich mal Zeit hab. Ist schon Klasse!

Viele Grüße
Jörg

Sorry Jörg,

hab nicht groß die Zeit, da jetzt nach Fehlern zu suchen, aber machs dir leicht,
nimm einfach "i" für die Zeile in Excel, geht genauso gut.

Public Sub Export()
Dim Excel
Set Excel = CreateObject("Excel.Application")  
Excel.Visible = True
Excel.Workbooks.Add

Dim aOutlook
Dim Contacts
Dim Contact
Dim Counter
Set aOutlook = Application
Set Contacts = aOutlook.ActiveExplorer.Selection
counter = Contacts.Count

for i =1 to Counter
  set Contact = Contacts.Item(i)
  Excel.cells(i,1).value=Contact.MailingAddressStreet
  Excel.cells(i,2).value=Contact.MailingAddressPostalCode
  Excel.cells(i,3).value=Contact.MailingAddressCity
  set Contact = Nothing
next i

set Contacts = Nothing
set aOutlook = Nothing
set Excel = Nothing

End Sub

Und wir haben so auch Speicher gespart...

(kein Dim Y)

Mfg
Benny

Hi Benny,

ich danke Dir für Deine Mühe, das Skript geht!

Es bleibt zwar reproduzierbar immer genau nach 232 Adressen mit ner Fehlermeldung (Laufzeitfehler -142852667 (ab404005) ) stecken, aber vielleicht krieg ich das selber raus (i dimensionieren?)

Danke Dir nochmals.

Wenn ich es hinbekommen habe, werde ich es mit Verweis auf Deine Vorarbeit posten, damit alle was davon haben.

Viele Grüße
Jörg

oh je, damit hatte ich auch oft zu kämpfen in anderen scripts.... habs mal probiert, bei mir ist nach ca. 400 Adressen schluss.... zu wenig arbeitsspeicher... soweit ich weiß ist das ein bekanntes problem mit outlook, er gibt den speicher nicht wieder frei "set contact = Nothing"

versuch mal:

Public Sub Export()
Dim Excel
Set Excel = CreateObject("Excel.Application")  
Excel.Visible = True
Excel.Workbooks.Add

Dim aOutlook
Dim Contacts
Dim Contact
Set aOutlook = Application
Set Contacts = aOutlook.ActiveExplorer.Selection

i = 1

for each Contact in Contacts
  Excel.cells(i,1).value=Contact.MailingAddressStreet
  Excel.cells(i,2).value=Contact.MailingAddressPostalCode
  Excel.cells(i,3).value=Contact.MailingAddressCity
  i = i +1
next contact

set Contacts = Nothing
set aOutlook = Nothing
set Excel = Nothing

End Sub

sonst fällt mir da im moment auch nix mehr zu ein...

Mfg
Benny

Hi Benny,

danke für Deine Unermüdlichkeit

249 Adressen kriegt er jetzt raus statt 232, dann wieder Laufzeitfehler.

Tja, ist dann doch nix mit 2800 Postanschriften für Druckerei aus Outlook 2003 auslesen...

(

Herzliche Grüße und vielen Dank für Deine Mühe.

Jörg

Doch das geht schon nimm halt VB und nicht VBA. Mach dir ein Formular. Ließ dir die Konakte ein und sortiere sie z.B. nach [fileas] dann kannst du bei einem abbruch an dem Index weitermachen.

bei uns sind es 192.000 Kontakte in dem öffentlichen Ordner, über VBA hatte ich auch immer wieder Probleme damit. Deswegen siehe meinen ersten Beitrag ganz oben, Outlook Addin und nicht VBA Makro gebastelt.

Oder exportier doch mal über die Outlook eigene Funktion, dann musste doch nur die ganzen Felder die du nicht brauchst einfach löschen (5min. arbeit). Also "Datei->Importieren/Exportieren" musst aber zuvor, wenn die Kontakte in einem öffentlichen Ordner liegen sollten, ein Kopie des Ordners in dein Postfach legen.

Mfg
Benny

Moin Benny,

könntest Du wohl noch dazu schreiben, an welche Stelle im Outlook dieser Code geschrieben werden muss?
Dann hätte Dein Beitrag den Titel "Anleitung" auch wirklich verdient...!

Ich hab's einfach mal in "DieseOutlookSitzung" kopiert.
Konnte aber nach einem Outlook-Neustart keine Änderungen feststellen.

Gruß CeMeNt

Moin CeMeNt,

schon mal ein Addin für Outlook mit VBA geschrieben? -Nein, ich auch nicht. In der Überschrift steht auch noch was von VB6, damit könnte unter Umständen Visual Basic 6.0 gemeint sein. Auch der kleine Hinweis auf den Inhalt des Formulars (Listbox, Button, Dialog) sollte aufgefallen sein, oder hast du unter VBA in Outlook schon irgendwo ein Formular entdeckt?

Daraus schließen wir, dass "dieser" Code in Outlook nirgendwo hingeschrieben wird.

Ist aber schnell geändert für VBA und das einfache "DieseOutlookSitzung" einfügen. Den hab ich aber nicht getestet.

Private Sub Command1_Click()
  On Error GoTo ErrHandler

Dim FileName As String
FileName = "c:\meinExceldaten.xls"  

Dim Excel As Object
Set Excel = CreateObject("Excel.Application")  
Excel.Visible = True
Excel.Workbooks.Open FileName

Dim x As Integer
Dim Y As Integer
x = Excel.worksheets.Item(1).usedrange.Columns.Count
Y = Excel.worksheets.Item(1).usedrange.Rows.Count

Dim i As Integer
Dim j As Integer

Dim aOutlook As Object
Dim Contacts As Object
Dim Contact As Object
Dim Filter As String
Dim DubContact As Object
Set aOutlook = Application 
Set Contacts = aOutlook.GetNameSpace("MAPI").Folders.Item("Öffentliche Ordner").Folders("Alle öffentlichen Ordner").Folders("Kontakte von Test")  
For j = 2 To Y    'Jede Zeile in der Excelliste lesen  
  Set Contact = Contacts.Items.Add
  For i = 1 To x  'Alle Eigenschaften in der Liste  
    Contact.itemProperties.Item(Excel.cells(1, i).Value).Value = Excel.cells(j, i).Value
  Next i
  Filter = "[LastName] = '" + Contact.LastName + "' AND [BusinessAddressPostalCode] = '" + Contact.BusinessAddressPostalCode + "' AND [BusinessAddressStreet] = '" + Contact.BusinessAddressStreet + "' AND [CompanyName]= '" + Contact.CompanyName + "'"  
  Set DubContact = Contacts.Items.Find(Filter)
  If DubContact Is Nothing Then
    Contact.Save
  End If
  Set Contact = Nothing
Next j

Exit Sub
ErrHandler:
If Err <> cdlCancel Then
    MsgBox Err.Description
End If
Ende:
End Sub