Export Contacts to Individual VCards

Hi all,
Quick thanks to everyone who makes this site the success it is.

Does anyone have the same problem as me?
I'd like to export my contacts to VCards. This means that each contact should be a separate file.

Any help?

GSD

First, select a bunch of contacts with ctrl + left mouse click. Then perform this macro. Contacts will be saved to C:\Data\Vcards . The directory must be present or you'll get an error.[VBA]Sub save_contacts()
Const mypath As String = "C:\Data\Vcards\"
Dim mycontact As Outlook.ContactItem
For Each mycontact In Outlook.ActiveExplorer.Selection
mycontact.SaveAs mypath & mycontact & ".vcf", Type:=olVCard
Next mycontact
End Sub[/VBA]

Nice one - and so fast, too!
That piece of code worked a treat, TX a million

GSD

Charlize, I am new to this forum and VBA, and I really like the code provided above. Is there a way to browse to a folder location when the macro runs instead of having it hard-coded to c:\Data\Vcards?

Yes, there are several ways. I'll give you one possibility. But the folder must already be present.[VBA]Option Explicit
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260
Type BrowseInfo
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszINSTRUCTIONS As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type
Declare Function SHGetPathFromIDListA Lib "shell32.dll" ( _
ByVal pidl As Long, _
ByVal pszBuffer As String) As Long
Declare Function SHBrowseForFolderA Lib "shell32.dll" ( _
lpBrowseInfo As BrowseInfo) As Long

Function BrowseFolder(Optional Caption As String = "") As String
Dim BrowseInfo As BrowseInfo
Dim FolderName As String
Dim ID As Long
Dim Res As Long
With BrowseInfo
.hOwner = 0
.pidlRoot = 0
.pszDisplayName = String$(MAX_PATH, vbNullChar)
.lpszINSTRUCTIONS = Caption
.ulFlags = BIF_RETURNONLYFSDIRS
.lpfn = 0
End With
FolderName = String$(MAX_PATH, vbNullChar)
ID = SHBrowseForFolderA(BrowseInfo)
If ID Then
Res = SHGetPathFromIDListA(ID, FolderName)
If Res Then
BrowseFolder = Left$(FolderName, InStr(FolderName, vbNullChar) - 1)
End If
End If
End Function
Sub Save_Contacts()
Dim mypath As String
Dim mycontact As Outlook.ContactItem
mypath = BrowseFolder(Caption:="Select folder to save contacts ...")
If mypath = vbNullString Then
MsgBox "No destinationfolder selected", vbInformation
Exit Sub
Else
For Each mycontact In Outlook.ActiveExplorer.Selection
mycontact.SaveAs mypath & "\" & mycontact & ".vcf", Type:=olVCard
Next mycontact
End If
End Sub
[/VBA]

This worked just fine and I appreciate all your help. Isn't there a way to call an mso object that would normally handle these types of requests - that would also allow you to create a folder if it wasn't there?

Have you browsed through the KB items ? You should try it ...[VBA]Option Explicit
Sub Choose_Directory_Or_Create_One()
Dim mypath As Variant
mypath = BrowseForFolder("C:\")
If mypath = False Then
MsgBox "No directory chosen !", vbExclamation
Else
MsgBox "Save to : " & mypath, vbInformation
End If
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function[/VBA]

Get the simple method and simple tool for exporting Vcard from outlook contacts. Vcard Exporter tool which is safely converts all MS Outlook Contacts to VCF format easily.