Private Sub Befehl2_Click()
RefreshGAL
End Sub
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 oApp 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
Set oApp = GetObject(, "Outlook.Application")
If Err.Number = 0 Then
MsgBox ("Please close Outlook!")
Else
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
SysCmd acSysCmdUpdateMeter, i
Set oContact = oGAL.Item(i)
If oContact.AddressEntryUserType = 0 Then
Set oUser = oContact.GetExchangeUser
Debug.Print oUser.FirstName
If oUser.LastName = "Blechinger" And oUser.FirstName = "Heinz" Then
MsgBox oUser.Fristname
UserIndex = UserIndex + 1
rs.AddNew
rs!FamilyName = oUser.LastName
rs!FirstName = oUser.FirstName
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
Err.Clear
End If
Else
MsgBox "You quit refreshing tbl_GAL.", vbOKOnly
End If
End Sub