VBATools

Poniższe makro pozwala na export kontaktów w formacie wizytówek ze wskazanego folderu Outlooka.Docelowym folderem jest katalog “C:\Kontakty”.

Option Explicit
Sub Export_PAB_to_vcfs()
'MVP OShon from VBATools.pl
 Dim myOlApp As Outlook.Application
 Dim objContact As ContactItem
 Dim olNs As NameSpace
 Dim NumItems&, i&, strName$
 Dim myFolder As MAPIFolder

 Set myOlApp = New Outlook.Application
 Set olNs = myOlApp.GetNamespace("MAPI")

 Dim bExitFor: bExitFor = False
 Do
  Set myFolder = Application.GetNamespace("MAPI").PickFolder
  If myFolder Is Nothing Then Exit Sub
  If myFolder.DefaultMessageClass <> "IPM.Contact" Then
   MsgBox "Wpisanie inf do folderu ''" & myFolder.Name & "'' nie jest możliwe." & vbCr _
   & "Wybierz folder kontaktów!", vbExclamation, " Informacja o błędzie VBATools.pl"
   Set myFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
  Else
   bExitFor = True
  End If
 Loop While Not bExitFor

 Set myFolder = Application.GetNamespace("MAPI").GetFolderFromID(myFolder.EntryID, myFolder.StoreID)
 NumItems = myFolder.Items.Count

On Error Resume Next
 MkDir "c:\kontakty"

For i = 1 To NumItems
 DoEvents
 Set objContact = myFolder.Items(i)
 If Not TypeName(objContact) = "Nothing" Then
  If Not objContact.FullName = "" Then
   strName = "C:\kontakty\" & objContact.FullName
   'If objContact.HasPicture Then objContact.Attachments.item(1).SaveAsFile strName & ".jpg"
   objContact.SaveAs strName & ".vcf", olVCard
  End If
 End If
Next

 Set myOlApp = Nothing
 Set olNs = Nothing
 Set myFolder = Nothing

 MsgBox "Gotowe"
 End Sub

Makro zmodyfikowane na potrzeby forumowicza Outlook pl.