agenda en contactpersonen autoatisch en dagelijks exproteren.

[roycke]

Tot gisteren kon ik draadloos synchroniseren met de exchange server op mijn werk.
Om veiligheids redenen hebben ze dit geblokkeerd, dus ik kan niet meer synchroniseren met mijn prive telefoon. De telefoon aansluiten op mijn werk pc is ook geblokkeerd.....
Nu zie ik nog maar een mogelijkheid die overblijft; Een VBA script die dagelijks mij agenda en contactpersonen naar huis doet mailen. En vervolgens thuis de 2 bestanden importeren en dan mijn iphone synchroniseren met de outlook thuis...
Echter macro's opnemen in excel lukt me nu vrij aardig, maar in outlook zit deze optie niet! Dus dit is het echte werk, 100% programmeren.
ik hoop dat er hier iemand is die me op de juiste weg wil helpen met zon script.

Alvast bedankt!
Gr. roy

 

[OctaFish]

Dit is een voorbeeldje van Helen Feddema om mails uit een zelf te kiezen mailmap te exporteren naar Excel. Ik heb het een beetje gemodificeerd zodat hij nu wat contactgegevens over haalt. Kijk maar eens of je er wat mee kunt; er zijn nog veel meer voorbeelden te vinden overigens...

Sub SaveContactsToExcel()
'Created by Helen Feddema
'Demonstrates pushing Contacts data to rows in an Excel worksheet

On Error GoTo ErrorHandler

Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim i As Integer
Dim lngCount As Long
Dim msg As Outlook.ContactItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object   'Must itm declare as Object because folders may contain different types of items
Dim strTitle As String
Dim strPrompt As String

''
    'Create Excel Spreadsheet
    Set appExcel = CreateObject("Excel.Application")
    appExcel.Application.Visible = True
    Set wkb = appExcel.Workbooks.Add
''    Set wkb = appExcel.ActiveWorkbook
    Set wks = wkb.ActiveSheet
''    Set wks = wkb.Sheets(1)
''    wks.Activate
    
    'Let user select a folder to export
    Set nms = Application.GetNamespace("MAPI")
    Set fld = nms.PickFolder
    If fld Is Nothing Then
       GoTo ErrorHandlerExit
    End If
    
   'Test whether selected folder contains Contacts
    If fld.DefaultItemType <> olContactItem Then
       MsgBox "Folder does not contain Contacts"
       GoTo ErrorHandlerExit
    End If
    
    lngCount = fld.Items.Count
    If lngCount = 0 Then
       MsgBox "No contacts to export"
       GoTo ErrorHandlerExit
    Else
       Debug.Print lngCount & " messages to export"
    End If

   'Adjust i (row number) to be 1 less than the number of the first body row
   i = 2
   
  ' Iterate through contact items in Contacts folder,
  ' and export a few fields from each item to a row in the Contacts worksheet
   For Each itm In fld.Items
      If itm.Class = olContact Then     'Process item only if it is a contacts item
         Set msg = itm
         i = i + 1
         Set rng = wks.Cells(i, 1)
         If msg.FullName <> "" Then rng.Value = msg.FullName
         Set rng = wks.Cells(i, 2)
         If msg.Email1Address <> "" Then rng.Value = msg.Email1Address
         Set rng = wks.Cells(i, 3)
         If msg.HomeAddress <> "" Then rng.Value = msg.HomeAddress
         Set rng = wks.Cells(i, 4)
         If msg.HomeAddressStreet <> "" Then rng.Value = msg.HomeAddressStreet
         Set rng = wks.Cells(i, 5)
         rng.Value = msg.HomeAddressCity
         Set rng = wks.Cells(i, 6)
         rng.Value = msg.FirstName
         Set rng = wks.Cells(i, 7)
         If msg.PrimaryTelephoneNumber <> "" Then rng.Value = msg.PrimaryTelephoneNumber
         Set rng = wks.Cells(i, 8)
         On Error Resume Next
         If msg.IMAddress <> "" Then rng.Value = msg.IMAddress
      End If
   Next itm

ErrorHandlerExit:
   Exit Sub

ErrorHandler:
   If Err.Number = 429 Then
      'Application object is not set by GetObject; use CreateObject instead
      If appExcel Is Nothing Then
         Set appExcel = CreateObject("Excel.Application")
         Resume Next
      End If
   Else
      MsgBox "Error No: " & Err.Number & "; Description: "
      Resume ErrorHandlerExit
   End If

End Sub