VBA Tools

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 & ".vcf"

 objContact.SaveAs strName, 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.