Login or Sign Up to become a member!
LessThanDot Sit Logo

LessThanDot

Community Wiki

Less Than Dot is a community of passionate IT professionals and enthusiasts dedicated to sharing technical knowledge, experience, and assistance. Inside you will find reference materials, interesting technical discussions, and expert tips and commentary. Once you register for an account you will have immediate access to the forums and all past articles and commentaries.

LTD Social Sitings

Lessthandot twitter Lessthandot Linkedin Lessthandot friendfeed Lessthandot facebook Lessthandot rss

Note: Watch for social icons on posts by your favorite authors to follow their postings on these and other social sites.

Navigation

Google Ads

Output Outlook Contacts to VCards

From Wiki

Jump to: navigation, search
textLine number Off | Hide | Select all
  1. Sub VCardOut()
  2.     Dim oFolder As Object
  3.     Dim oContact As ContactItem
  4.     Dim sPath As String
  5.     Dim sName As String
  6.     Dim sVCard As String
  7.     Dim f As Object
  8.     Dim fs As Object
  9.     Dim i As Integer
  10.    
  11.    
  12.         Set fs = CreateObject("Scripting.FileSystemObject")
  13.         Set oFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
  14.        
  15.         sPath = "C:\Docs\"
  16.  
  17.         '' Loop through all of the items in the folder.
  18.         For i = 1 To oFolder.Items.Count
  19.             Set oContact = oFolder.Items(i)
  20.            
  21.             sName = oContact.FullNameAndCompany & ".vcf"
  22.        
  23.             If Trim(sName) = ".vcf" Then sName = oContact.EntryID & ".vcf"
  24.                
  25.             Set f = fs.CreateTextFile(sPath & sName)
  26.    
  27.             sVCard = "BEGIN:VCARD" & vbCrLf
  28.             sVCard = sVCard & "VERSION:2.1" & vbCrLf
  29.            
  30.             sVCard = sVCard & "FN:" & oContact.FullName & vbCrLf
  31.            
  32.             sVCard = sVCard & "N:" & oContact.LastName & ";" & oContact.FirstName & ";" _
  33.                 & oContact.MiddleName & ";" & oContact.Title & ";" & vbCrLf
  34.            
  35.             sVCard = sVCard & "NICKNAME:" & oContact.NickName & vbCrLf
  36.            
  37.             sVCard = sVCard & "ADR;HOME;ENCODING=QUOTED-PRINTABLE:;;" _
  38.                 & Replace(oContact.HomeAddress & "", vbCrLf, "=0D=0A") & ";" _
  39.                 & Replace(oContact.HomeAddressCity & "", vbCrLf, "=0D=0A") & ";" _
  40.                 & Replace(oContact.HomeAddressCountry & "", vbCrLf, "=0D=0A") & vbCrLf
  41.              
  42.             sVCard = sVCard & "ADR;WORK;ENCODING=QUOTED-PRINTABLE:;;" _
  43.                 & Replace(oContact.BusinessAddress & "", vbCrLf, "=0D=0A") & ";" _
  44.                 & Replace(oContact.BusinessAddressCity & "", vbCrLf, "=0D=0A") & ";" _
  45.                 & Replace(oContact.BusinessAddressCountry & "", vbCrLf, "=0D=0A") & vbCrLf
  46.            
  47.             sVCard = sVCard & "BDAY:" & Format(oContact.Birthday, "yyyymmdd") & vbCrLf
  48.            
  49.             sVCard = sVCard & "EMAIL;PREF;INTERNET:" & oContact.Email1Address & vbCrLf
  50.            
  51.             '' Repeat as necessary for each email address
  52.             sVCard = sVCard & "EMAIL;INTERNET:" & oContact.Email2Address & vbCrLf
  53.            
  54.             sVCard = sVCard & "ORG:" & oContact.CompanyName & ";" & oContact.Department & vbCrLf
  55.            
  56.             sVCard = sVCard & "TEL;CELL;VOICE:" & oContact.MobileTelephoneNumber & vbCrLf
  57.            
  58.             sVCard = sVCard & "TEL;HOME;FAX:" & oContact.HomeFaxNumber & vbCrLf
  59.            
  60.             sVCard = sVCard & "TEL;HOME;VOICE:" & oContact.HomeTelephoneNumber & vbCrLf
  61.            
  62.             sVCard = sVCard & "TEL;WORK;FAX:" & oContact.BusinessFaxNumber & vbCrLf
  63.            
  64.             sVCard = sVCard & "TEL;WORK;VOICE:" & oContact.BusinessTelephoneNumber & vbCrLf
  65.            
  66.             sVCard = sVCard & "TITLE:" & oContact.JobTitle & vbCrLf
  67.            
  68.             sVCard = sVCard & "URL;HOME:" & oContact.PersonalHomePage & vbCrLf
  69.            
  70.             sVCard = sVCard & "URL;WORK:" & oContact.BusinessHomePage & vbCrLf
  71.            
  72.             sVCard = sVCard & "REV:20090225T232716Z" & vbCrLf
  73.             sVCard = sVCard & "End: VCARD"
  74.            
  75.             f.WriteLine sVCard
  76.             f.Close
  77.         Next
  78.    
  79.     End Sub

647 Rating: 2.0/5 (11 votes cast)

Retrieved from "http://wiki.lessthandot.com/index.php/Output_Outlook_Contacts_to_VCards"

Powered by MediaWiki GNU Free Documentation License 1.2
Valid XHTML | Valid CSS