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
|