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

[nomail]

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

date: 2004/07/27 14:47:21;  author: mleonhardt;  state: Exp;  lines: +31 -1

Log Message:
- extending Exportmacro: user can now select category of the contacts to export
=====================================================================
Index: sync/tools/idgenexport.bas
diff -u sync/tools/idgenexport.bas:1.6 sync/tools/idgenexport.bas:1.7
--- sync/tools/idgenexport.bas:1.6      Thu Jul 15 09:38:50 2004
+++ sync/tools/idgenexport.bas  Tue Jul 27 14:47:21 2004
@@ -126,6 +126,22 @@
     GetAddressofFunction = add
 End Function
 
+' This function shows the Outlook Selectcategory Dialog and returns the chosen 
category
+Private Function GetSelectedCategory() As String
+    Dim appolApp As Outlook.Application
+    Dim olApptItem As Outlook.AppointmentItem
+    
+    'Create an instance of the application
+    Set appolApp = New Outlook.Application
+    'Create appointment item
+    Set olApptItem = appolApp.CreateItem(olAppointmentItem)
+
+    'Display the Show categories dialog
+    olApptItem.ShowCategoriesDialog
+    GetSelectedCategory = olApptItem.Categories
+    olApptItem.Delete
+End Function
+
 Sub KontaktIDExport()
   Dim objApp As Application
   Dim objNS As NameSpace
@@ -140,6 +156,7 @@
   Dim ItemWithoutCount As Integer
   Dim catdir As String
   Dim destdir As String
+  Dim selectedcategory As String
   
   Const defaultdestdir = "c:\"
   
@@ -164,6 +181,13 @@
     MsgBox "Der Zielordner existiert nicht - bitte passen sie das Macro 
entsprechend an!"
   Else
 
+  ' show infodialog
+  MsgBox "Bitte wählen Sie im nachfolgenden Dialog eine gewünschte Kategorie 
von Kontakten aus. " _
+    + Chr(13) + "Bitte nicht mehrere Kategorien auswählen. " _
+    + Chr(13) + "Wenn Sie keine Kategorie auswählen, werden alle Kontakte 
exportiert.", vbOKOnly, "pro|business Kontaktexport by Matthias Leonhardt"
+    
+  selectedcategory = GetSelectedCategory
+  
   objContacts.Items.ResetColumns
   
   Set colItems = objContacts.Items
@@ -190,7 +214,13 @@
 '        Else
           catdir = destdir
 '        End If
-        objItem.SaveAs catdir & "\" & objItem.GovernmentIDNumber & ".vcd", 
olVCard
+        If (selectedcategory <> "") Then
+          If (InStr(1, objItem.Categories, selectedcategory, vbTextCompare) > 
0) Then
+            objItem.SaveAs catdir & "\" & objItem.GovernmentIDNumber & ".vcd", 
olVCard
+          End If
+        Else
+          objItem.SaveAs catdir & "\" & objItem.GovernmentIDNumber & ".vcd", 
olVCard
+        End If
       End If
     Next