Hallo ihr Coder,

dass VBA für viele Praktikanten, Werkstudenten oder alte Hasen im Büro immer wieder eine Herausforderung darstellt ist nichts neues und erging mir gleich. Hab trotz meines Informatikstudiums oft auf die Hilfe der Online-Community zurück greifen müssen und will jetzt ein bisschen was zurück geben.

Mit diesem Beitrag möchte ich mich einem Thema widmen, welches zwar schon einige male Behandelt wurde aber ich noch nie einen einfachen Copy-Paste Code gesehen hab, der Einsteigern taugt.

Die Folgenden Codes funktionieren mit Access 2007 und Excel 2010 und müssten (wenn ihr die jeweilge Software habt) ohne größeren Aufwand sofort bei euch funktionieren. Mit dem Makros könnt Ihr die Globale Adressliste eures Outlooks auslesen und in Access oder Excel integrieren (also in eure ExcelSheets oder in eure Access Tabellen schreiben). In großen Firmen ein oftmals nützliches Tool.

----------------------------------------------------------------------------------------------------- Excel 2010 -----------------------------------------------------------------------------------------------------

Alles was Anpassungsbedürftig ist hab ich mit Kommentaren versehen.

WICHTIG: Bevor ihr dieses Makro startet müsst ihr noch eine Tabelle mit dem Namen GAL anlegen. Bzw ihr könnt sie nennen wie ihr wollt, müsst es dann aber unten anpassen. Wer es also leicht haben will einfach eine Tabelle "GAL" nennen und fertig.

Sub RefreshGAL()

    Dim appOL As Object
    Dim oGAL As Object
    Dim oContact As Object
    Dim oUser As Object
    Dim arrUsers(1 To 65000, 1 To 11) As String
    Dim UserIndex As Long
    Dim i As Long
   

On Error Resume Next 
Set oApp = GetObject(, "Outlook.Application")
If Err.Number = 0 Then 'Tests if Outlook is started
   MsgBox ("Please close Outlook!")
Else 'Starts the Import if Outlook is closed

    ---> Ich glaube die Range könnt ihr erstmal so übernehmen. Sollte eure Firma mehr als 75000 Einträge in der GAL haben, dann wäre eine Anpassung erforderlich

    Range(A2, Q75000).Clear

    Set appOL = CreateObject("Outlook.Application")

    -> Ihr müsste natürlich nicht die Globale Adressliste nehmen, ihr könnt auch jede andere Adressliste nehmen die ihr im Outlook habt. Einfach in Outlook gehen, Adressbücher öffnen und schauen was es da so gibt. Aber ich glaube die GAL ist meistens das interessanteste.
    Set oGAL = appOL.GetNameSpace("MAPI").AddressLists("Globale Adressliste").AddressEntries

    For i = 1 To oGAL.Count ' Fügt alle Einträge ein
        Set oContact = oGAL.Item(i)
        If oContact.AddressEntryUserType = 0 Then
            Set oUser = oContact.GetExchangeUser
            If Len(oUser.LastName) > 0 Then
                UserIndex = UserIndex + 1

                -> Hier wird es etwas tricky, die Namen nach dem Punkt also LastName, FirstName und so weiter können variieren. Einfach mal Outlook Adressbuch Attribute Googlen und schauen was es da so alles gibt. Ich denke mit den folgenden seid ihr erstmal gut bedient. Falls ihr etwas nicht gebrauchen könnt einfach die Zeile löschen und die Zahlen für die Spalten (folgen auf UserIndex) anpassen.

           
                arrUsers(UserIndex, 1) = oUser.LastName
                arrUsers(UserIndex, 2) = oUser.FirstName
                arrUsers(UserIndex, 3) = oUser.Alias
                arrUsers(UserIndex, 4) = oUser.PrimarySMTPAddress
                arrUsers(UserIndex, 5) = oUser.Department
                arrUsers(UserIndex, 6) = oUser.BusinessTelephoneNumber
                arrUsers(UserIndex, 7) = oUser.CompanyName
                arrUsers(UserIndex, 8) = oUser.StreetAddress
                arrUsers(UserIndex, 9) = oUser.PostalCode
                arrUsers(UserIndex, 10) = oUser.City
                arrUsers(UserIndex, 11) = oUser.StateOrProvince

            End If
        End If
    Next i

    appOL.Quit

    If UserIndex > 0 Then
        Sheets("GAL").Range("A3").Resize(UserIndex, UBound(arrUsers, 2)).Value = arrUsers
    End If

    Set appOL = Nothing
    Set oGAL = Nothing
    Set oContact = Nothing
    Set oUser = Nothing
    Erase arrUsers
        

Sheets("GAL").Range("D1").Value = Date

   Err.Clear  ' Vorherige Fehlernummer löschen
 
End If 'End if of the "Is Outlook open" check

End Sub

--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

------------------------------------------------------------------------------------- ACCESS 2007 ----------------------------------------------------------------------------------------------------------------

Selbes Spiel wie zuvor. Tabellenname (ich hatte tbl_GAL) und Feldnamen anpassen.

Hier der Code:

Sub RefreshGAL()
   
    If MsgBox("Sure you want to refresh table: tbl_GAL?", vbYesNo, "Attention") = vbYes Then
        MsgBox "Mind the Progressbar below - Press Okay", vbOKOnly, "GAL Refreshing started"
       
        Dim appOL As Object
        Dim oGAL As Object
        Dim oContact As Object
        Dim oUser As Object
        Dim arrUsers(1 To 65000, 1 To 11) As String
        Dim UserIndex As Long
        Dim i As Long
        Dim rs As DAO.Recordset
        Dim DB As DAO.Database
        Set DB = CurrentDb()
       
        On Error Resume Next  ' Ignore Errors
        Set oApp = GetObject(, "Outlook.Application") 'Wants to provoke an Error if Outlook is started
        If Err.Number = 0 Then 'Tests if Outlook is started
           MsgBox ("Please close Outlook!")
        Else 'Starts the Import if Outlook is closed
       
          
       
            Set appOL = CreateObject("Outlook.Application")
            Set oGAL = appOL.GetNameSpace("MAPI").AddressLists("Globale Adressliste").AddressEntries
           
            SysCmd acSysCmdInitMeter, "GAL Refreshing: ", oGAL.Count
           
            Set rs = DB.OpenRecordset("tbl_GAL", dbOpenDynaset, dbSeeChanges)
            For i = 1 To oGAL.Count ' Fügt alle Einträge ein
                SysCmd acSysCmdUpdateMeter, i
       
                Set oContact = oGAL.Item(i)
                If oContact.AddressEntryUserType = 0 Then
                    Set oUser = oContact.GetExchangeUser
                    If Len(oUser.LastName) > 0 Then
                        UserIndex = UserIndex + 1
                        rs.AddNew
                            'rs![Key-GAL] = UserIndex
                            rs!FamilyName = oUser.LastName
                            rs!FirstName = oUser.FirstName
                            rs!EmailAddress = oUser.PrimarySMTPAddress
                            rs!Alias = oUser.Alias
                            rs!Location = oUser.City
                            rs!Department = oUser.Department
                            rs!PhoneNumber = oUser.BusinessTelephoneNumber
                            rs!LastUpdate = Date
                        rs.Update
                        Debug.Print "User: " & UserIndex & oUser.LastName & " wurde geschrieben."
                    End If
                End If
            Next i
            rs.Close
            SysCmd acSysCmdRemoveMeter
       
            appOL.Quit
       
            Set appOL = Nothing
            Set oGAL = Nothing
            Set oContact = Nothing
            Set oUser = Nothing
            Erase arrUsers
                
            'Set DB = Nothing
            'Set rs = Nothing
           
           Err.Clear  ' Vorherige Fehlernummer löschen
        
        End If 'End if of the "Is Outlook open" check
       
    Else
        MsgBox "You quit refreshing tbl_GAL.", vbOKOnly
    End If
End Sub

---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

Beide Codes funktionieren und werden so von mir eingesetzt.

Den Access Code habe ich eben erst geschrieben und wird von mir noch verbessert - so dass damit immer die GAL Tabelle aktuell gehalten werden kann und wird hier noch gepostet.

MFG

vbaDave