[Phpgroupware-cvs] sync/tools/idgenexport.bas, 1.1

[nomail]

Update of /sync/tools
Added Files:
        Branch: 
          idgenexport.bas

date: 2004/07/12 19:40:38;  author: mleonhardt;  state: Exp;

Log Message:
- outlook macro to set a unique id to each contact in a given contact folder 
and export all contacts of a folder (also public folder) to a specific dir in 
vcard format
=====================================================================
' $Id: idgenexport.bas,v 1.2 2004/07/11 20:21:23 mkaemmerer Exp $
Sub SetUniqueIDsToFolder()
  Dim objApp As Application
  Dim objNS As NameSpace
  Dim objContacts As MAPIFolder
  Dim colItems As Items
  Dim objItem As Object
  Dim strAddress As String
  Dim blnFound As Boolean
  Dim ItemWithCount As Integer
  Dim ItemWithoutCount As Integer
  
  ' connect to Outlook
  Set objApp = CreateObject("Outlook.Application")
  Set objNS = objApp.GetNamespace("MAPI")
  
  ' get Addressbook to create Unique IDs
  ' eventually use Item(1) - shouldn't be a remote adressbook because its 
faster...
  Set myAddressList = objNS.AddressLists.Item(2)
  ' Set myAddressList = Application.Session.AddressLists("Personal Address 
Book")
  Set myAddressEntries = myAddressList.AddressEntries
  
  ' get folder to search (Select Folder Dialog)
  Set objContacts = objNS.PickFolder
  
  If Not (objContacts Is Nothing) Then
  
  objContacts.Items.ResetColumns
  
  Set colItems = objContacts.Items
  'colItems.SetColumns ("GovernmentIDNumber")
  ItemWithoutCount = objContacts.Items.Count
  
  ItemWithCount = 0
  ItemWithoutCount = 0
  
    For Each objItem In colItems
      If TypeName(objItem) = "ContactItem" Then
        If (objItem.GovernmentIDNumber <> "") Then
            ItemWithCount = ItemWithCount + 1
            blnFound = True
        Else
            ItemWithoutCount = ItemWithoutCount + 1
            ' create temporary Addressbookentry
            Set newEntry = myAddressEntries.Add("ContactItem", 
"idcreatorentry", "")
            ' new Adressentries have a greatful Unique ID...
            objItem.GovernmentIDNumber = newEntry.ID
            newEntry.Delete
            objItem.Save
        End If
        objItem.SaveAs "F:\temp\7\" & objItem.GovernmentIDNumber & ".vcd", 
olVCard
      End If
    Next

  MsgBox (CStr(ItemWithCount) + " Einträge mit ID gefunden, " + _
     CStr(ItemWithoutCount) + " Einträge ohne ID gefunden und mit ID versehen.")
  
  Else
    MsgBox "kein Verzeichnis ausgewählt - Abbruch"
  End If

  Set objItem = Nothing
  Set colItems = Nothing
  Set objContacts = Nothing
  Set objNS = Nothing
  Set objApp = Nothing
End Sub