[Last Call] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 584
  • Last Modified:

Export Access record to vCard

Dear Experts,

I have a basic Access 2003 contacts database which I would like to add a command button in a form to create a vcard for that record which I can drag & drop into my outlook contacts (Outlook 2003).  Whilst this isn't the ideal method to keep both up to date the master table in the access has too many extra fields to have a linked table.  I thought it would be easier to create a vcard that could be dragged & dropped into contacts so I can get around and potential duplicate issues.

I have matched the Access fields to an existing vcard as follows (Access Field to Outlook Field)

Business City to Business City
Business Fax to Business Fax
Business Phone to Business Phone
Business Postal Code to Business Postal Code
Business State to Business State
Business Street to Business Street
Business Street 2 to Business Street 2
Business Street 3 to Business Street 3
Company - to  Company
Company Main Phone to Company Main Phone
Department - to  Department
E-mail Address to E-mail Address
E-mail 2 Address to E-mail 2 Address
First Name to First Name
Home City to Home City
Home Fax to Home Fax
Home Phone to Home Phone
Home Postal Code to Home Postal Code
Home State to Home State
Home Street to Home Street
Home Street 2 to Home Street 2
Home Street 3 to Home Street 3
Job Title to Job Title
Last Name to Last Name
Mobile Phone to Mobile Phone
Notes - to  Notes

Does anyone have a piece of code for this & perhaps slot in 2 of the fields so I can see where to added the rest in.

Many thanks
0
correlate
Asked:
correlate
  • 8
  • 8
1 Solution
 
rockiroadsCommented:
I have this which maybe you can adapt to your use
Fill in the data you want (Ive got hardcoded as example)


Public Sub CreateVCard()
   
    Dim objApp As Object
    Dim objNamespace As Object
    Dim objContacts As Object
    Const olFolderContacts = 10
    Const olContactItem = 2
   
    Set objApp = CreateObject("Outlook.Application")
    Set objNamespace = objApp.GetNamespace("MAPI")
    Set objContacts = objApp.CreateItem(olContactItem)
   
    objContacts.firstName = "AAAA"
    objContacts.LastName = "AAAA"
    objContacts.Email1Address = "Email@Addr.com"
    objContacts.Title = "Mr"
    objContacts.CompanyName = "Company"
    objContacts.BusinessTelephoneNumber = "OfficePhone"
    objContacts.MobileTelephoneNumber = "MobilePhone"
   
    objContacts.BusinessAddressCity = "BusCity"
    objContacts.BusinessAddressCountry = "BusCountry"
    objContacts.BusinessAddressPostalCode = "Zip Code"
    objContacts.BusinessAddressState = "CA"
    objContacts.BusinessAddressStreet = "BusStreet"
    objContacts.BusinessTelephoneNumber = "BusTelNumber"
   
    objContacts.HomeAddressCity = "HomeCity"
    objContacts.HomeAddressCountry = "HomeCountry"
    objContacts.HomeAddressPostalCode = "Zip Code 2"
    objContacts.HomeAddressState = "AC"
    objContacts.HomeAddressStreet = "HomeStreet"
    objContacts.HomeTelephoneNumber = "HomeTelNumber"
   
    objContacts.Save

    Set objContacts = Nothing
    Set objNamespace = Nothing
    Set objApp = Nothing
End Sub
0
 
correlateAuthor Commented:
Thats brilliant, however it does create duplicates, is there either a way to either:

Just view the vCard rather than save it as by saving it so it can be manually drag n dropped (hopefully thereby allowing outlook to allow you to update an existing record).

Or alternatively look up the vcard "profession" field and update or add dependant upon the match (I would match up the "profession field with the access record's unique ID - objContacts.Profession = ID

Any advice?
0
 
rockiroadsCommented:
Only thing I can suggest is to do a find on the contacts
eg
    Dim oApp As Object
    Dim oNS As Object
    Dim oF As Object
    Dim oC As Object
    Const olFolderContacts = 10

    Set oApp = CreateObject("Outlook.Application")
    Set oNS = oApp.GetNamespace("MAPI")
    Set oF = oNS.GetDefaultFolder(olFolderContacts)
   
    Set oC = oF.items.Find("[Profession] = 'OverpaidDirector'")
    If Not TypeName(oC) = "Nothing" Then
        Debug.Print "Found it", oC.FileAs
    Else
        Debug.Print "not found"
    End If

0
Free learning courses: Active Directory Deep Dive

Get a firm grasp on your IT environment when you learn Active Directory best practices with Veeam! Watch all, or choose any amount, of this three-part webinar series to improve your skills. From the basics to virtualization and backup, we got you covered.

 
correlateAuthor Commented:
Just so I can understand this one
{Set oC = oF.items.Find("[Profession] = 'OverpaidDirector'")} performs the look up, if its not then {If Not TypeName(oC) = "Nothing" Then} puts in the word "nothing" as someone's name. Presumably then the statement can be changed to tsome sort of "IF Yes" & then use {TypeName(oC) = "AAAA" to update the details (all the fields less the [profession] one which would be used as the unique ID).?
0
 
rockiroadsCommented:
The example I posted just dumps the findings in the immediate window
Your on the right line

You wanna add when nowt there so you could do this

if TypeName(oC) = "Nothing" Then
   'create new contact



You do not do TypeName(oC) = "AAAA

oC is an object which is either null or contains the contact item details
to access items in oC, you do oC.<<property>> and these properties are the same as when u created it
0
 
correlateAuthor Commented:
thanks for the tip - I'll have a play around with this over the weekend
0
 
rockiroadsCommented:
No worries, have a good un
0
 
correlateAuthor Commented:
Hi Rockiroads

Had a play around with this and I'm kind of 1/2 way there.  The code I have is below & this is what it does so far, if the lookup ([Profession] = 'OverpaidDirector) returns a negative result (i.e in outlook profession does not equal 'OverpaidDirector') then it creates the contact all fine.  If there is a match then it does nothing, & there is no message box.  How can I get it to update the contact when there is a positive match?

Private Sub Command256_Click()
Dim oApp As Object
    Dim oNS As Object
    Dim oF As Object
    Dim oC As Object
    Const olFolderContacts = 10

    Set oApp = CreateObject("Outlook.Application")
    Set oNS = oApp.GetNamespace("MAPI")
    Set oF = oNS.GetDefaultFolder(olFolderContacts)
   
    Set oC = oF.items.Find("[Profession] = 'OverpaidDirector'")
    If Not TypeName(oC) = "Nothing" Then
        Debug.Print "Found it", oC.FileAs
    Else
Dim objApp As Object
    Dim objNamespace As Object
    Dim objContacts As Object
    Const olContactItem = 2
    Set objApp = CreateObject("Outlook.Application")
    Set objNamespace = objApp.GetNamespace("MAPI")
    Set objContacts = objApp.CreateItem(olContactItem)
   
    objContacts.Profession = "OverpaidDirector"
    objContacts.firstName = "BBB"
    objContacts.LastName = "AAAA"
    objContacts.Email1Address = "Email@Addr.com"
    objContacts.Title = "Mr"
    objContacts.CompanyName = "Company"
    objContacts.BusinessTelephoneNumber = "OfficePhone"
    objContacts.MobileTelephoneNumber = "MobilePhone"
   
    objContacts.BusinessAddressCity = "BusCity"
    objContacts.BusinessAddressCountry = "BusCountry"
    objContacts.BusinessAddressPostalCode = "Zip Code"
    objContacts.BusinessAddressState = "CA"
    objContacts.BusinessAddressStreet = "BusStreet"
    objContacts.BusinessTelephoneNumber = "BusTelNumber"
   
    objContacts.HomeAddressCity = "HomeCity"
    objContacts.HomeAddressCountry = "HomeCountry"
    objContacts.HomeAddressPostalCode = "Zip Code 2"
    objContacts.HomeAddressState = "AC"
    objContacts.HomeAddressStreet = "HomeStreet"
    objContacts.HomeTelephoneNumber = "HomeTelNumber"
    objContacts.Save
    Set objContacts = Nothing
    Set objNamespace = Nothing
    Set objApp = Nothing
    End If
End Sub


So its something in around this bit of the code:

 Set oC = oF.items.Find("[Profession] = 'OverpaidDirector'")
    If Not TypeName(oC) = "Nothing" Then
        Debug.Print "Found it", oC.FileAs
    Else

Can you help?
0
 
rockiroadsCommented:
Your getting th variables mixed up and duplicated

Remember oC is same as objContacts, and it contains populated contact

lets rename it to be consistent

eg


Private Sub Command256_Click()
   
    Dim objApp As Object
    Dim objNamespace As Object
    Dim oF As Object
    Dim objContacts As Object
    Const olFolderContacts = 10
    Const olContactItem = 2
   
    Set objApp = CreateObject("Outlook.Application")
    Set objNamespace = oApp.GetNamespace("MAPI")
    Set oF = oNS.GetDefaultFolder(olFolderContacts)
   
    Set objContacts = oF.items.Find("[Profession] = 'OverpaidDirector'")
    If Not TypeName(objContacts) = "Nothing" Then
        Debug.Print "Found it", objContacts.FileAs
    Else
        'Create new item if not found
        Set objContacts = objApp.CreateItem(olContactItem)
    End If
   
    objContacts.Profession = "OverpaidDirector"
    objContacts.firstName = "BBB"
    objContacts.LastName = "AAAA"
    objContacts.Email1Address = "Email@Addr.com"
    objContacts.Title = "Mr"
    objContacts.CompanyName = "Company"
    objContacts.BusinessTelephoneNumber = "OfficePhone"
    objContacts.MobileTelephoneNumber = "MobilePhone"
   
    objContacts.BusinessAddressCity = "BusCity"
    objContacts.BusinessAddressCountry = "BusCountry"
    objContacts.BusinessAddressPostalCode = "Zip Code"
    objContacts.BusinessAddressState = "CA"
    objContacts.BusinessAddressStreet = "BusStreet"
    objContacts.BusinessTelephoneNumber = "BusTelNumber"
   
    objContacts.HomeAddressCity = "HomeCity"
    objContacts.HomeAddressCountry = "HomeCountry"
    objContacts.HomeAddressPostalCode = "Zip Code 2"
    objContacts.HomeAddressState = "AC"
    objContacts.HomeAddressStreet = "HomeStreet"
    objContacts.HomeTelephoneNumber = "HomeTelNumber"
    objContacts.Save
   
    Set objContacts = Nothing
    Set objNamespace = Nothing
    Set objApp = Nothing
End Sub


0
 
correlateAuthor Commented:
Hi

I have cleaned up the coding and started to try and add the update bit (if "[Profession] = 'OverpaidDirector'") but Im getting seriously out of my depth now. The bit I am using for the update is this &

    Set objContacts = oF.items.Find("[Profession] = 'OverpaidDirector'")
    If Not TypeName(objContacts) = "Nothing" Then
    With objContact
    rst.Edit
    .CompanyName = rst.Fields("Result")
     Debug.Print "Found it", objContacts.FileAs
    Else

But I am getting a compile error  "Else without IF" and cant work out where to insert the "IF".  Also I wanted to check to see if the method I am using to update the outlook field is correct

A copy of the full code is below  Can anyone help???

Many thanks

Private Sub Command256_Click()
    Dim objApp As Object
    Dim objNamespace As Object
    Dim oF As Object
    Dim objContacts As Object
    Const olFolderContacts = 10
    Const olContactItem = 2
   
    Set objApp = CreateObject("Outlook.Application")
    Set objNamespace = objApp.GetNamespace("MAPI")
    Set oF = objNamespace.GetDefaultFolder(olFolderContacts)
   
    Set objContacts = oF.items.Find("[Profession] = 'OverpaidDirector'")
    If Not TypeName(objContacts) = "Nothing" Then
    With objContact
    rst.Edit
    .CompanyName = rst.Fields("Result")
     Debug.Print "Found it", objContacts.FileAs
    Else
        'Create new item if not found
        Set objContacts = objApp.CreateItem(olContactItem)
    End If
    objContacts.Profession = "OverpaidDirector"
    objContacts.FirstName = "BBB"
    objContacts.LastName = "AAAA"
    objContacts.Email1Address = "Email@Addr.com"
    objContacts.Title = "Mr"
    objContacts.CompanyName = "Company"
    objContacts.BusinessTelephoneNumber = "OfficePhone"
    objContacts.MobileTelephoneNumber = "MobilePhone"
    objContacts.BusinessAddressCity = "BusCity"
    objContacts.BusinessAddressCountry = "BusCountry"
    objContacts.BusinessAddressPostalCode = "Zip Code"
    objContacts.BusinessAddressState = "CA"
    objContacts.BusinessAddressStreet = "BusStreet"
    objContacts.BusinessTelephoneNumber = "BusTelNumber"
    objContacts.HomeAddressCity = "HomeCity"
    objContacts.HomeAddressCountry = "HomeCountry"
    objContacts.HomeAddressPostalCode = "Zip Code 2"
    objContacts.HomeAddressState = "AC"
    objContacts.HomeAddressStreet = "HomeStreet"
    objContacts.HomeTelephoneNumber = "HomeTelNumber"
    objContacts.Save
   
    Set objContacts = Nothing
    Set objNamespace = Nothing
    Set objApp = Nothing
End Sub

0
 
rockiroadsCommented:
Well you have added a With statement, you know your supposed to end that?
0
 
correlateAuthor Commented:
I see but I don't really know how - I tried sticking in an End If as well as an End before the else, but no joy.  The code I slotted in there was a bit of a copy & paste from other EE questions & I don't really know what i'm doing here.  Is there any chance of showing me what it should read.  Sorry for being useless on this one, but I'm literally guessing here
0
 
rockiroadsCommented:
Usually its what you start with that you end it

eg

if

end if

while

wend (how odd, end after w, lol)

and of course

with

End With


This is why indenting is important. Makes your code more readable. Its not much more effort to hit the tab key. Im only saying this because you will find what code inside what if or loop exists easier.
So since you started with a With, you got to end it with end with

remember to open and close in order

this is invalid

if ..

with ..

end if

end with

it has to be

if

with

end with

end if
0
 
correlateAuthor Commented:
Mate thanks for your help with that - have added in the end with & am now various errors around the update bit.  I think I've lost the will to live on this one
0
 
correlateAuthor Commented:
HI RockiRoads have decided to split the question in two and submit another question regarding updating a found contact & give you the points as you have worked hard on this one.
0
 
rockiroadsCommented:
ok, thanks. sorry for the delay. Ive been busy at work and not had a chance to get into EE. I will try find time today, though most likely it would be in this evening.
0

Featured Post

Visualize your virtual and backup environments

Create well-organized and polished visualizations of your virtual and backup environments when planning VMware vSphere, Microsoft Hyper-V or Veeam deployments. It helps you to gain better visibility and valuable business insights.

  • 8
  • 8
Tackle projects and never again get stuck behind a technical roadblock.
Join Now