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

[nomail]

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

date: 2004/11/26 12:34:57;  author: fipsfuchs;  state: Exp;  lines: +161 -22

Log Message:
new version from internal CVS moved to original project
=====================================================================
Index: sync/tools/idgenexport.bas
diff -u sync/tools/idgenexport.bas:1.7 sync/tools/idgenexport.bas:1.8
--- sync/tools/idgenexport.bas:1.7      Tue Jul 27 14:47:21 2004
+++ sync/tools/idgenexport.bas  Fri Nov 26 12:34:57 2004
@@ -1,5 +1,4 @@
 ' $Id$
-Attribute VB_Name = "idgenexport"
 Option Explicit
 
 Public m_CurrentDirectory As String 'The current directory
@@ -131,6 +130,11 @@
     Dim appolApp As Outlook.Application
     Dim olApptItem As Outlook.AppointmentItem
     
+  ' 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"
+    
     'Create an instance of the application
     Set appolApp = New Outlook.Application
     'Create appointment item
@@ -142,18 +146,124 @@
     olApptItem.Delete
 End Function
 
+' This function shows the Outlook Selectcategory Dialog and returns the chosen 
category
+Private Function GetSelectedCategory2000(objContacts As MAPIFolder) As String
+  Dim appolApp As Outlook.Application
+  Dim objItem As Variant
+  Dim colItems As Items
+  Dim KategorieSelector As New KategoriesForm
+  Dim Categories() As String
+  Dim CatI As Integer
+  Dim CatCount As Integer
+  Dim SearchedCount As Integer
+  Dim Found As Boolean
+  
+  Set colItems = objContacts.Items
+  
+  MsgBox "Bitte klicken sie auf ok, damit der ausgwählte Outlookfolder nach 
verfügbaren Kategorien " _
+    + "durchsucht wird. Dies kann einige Minuten dauern."
+  
+  CatCount = 0
+  SearchedCount = 0
+  For Each objItem In colItems
+    SearchedCount = SearchedCount + 1
+    If TypeName(objItem) = "ContactItem" Then
+      If (objItem.Categories <> "") Then
+        Found = False
+        For CatI = 0 To CatCount - 1
+          If (Categories(CatI) = Trim(objItem.Categories)) Then
+            Found = True
+          End If
+        Next CatI
+        If Not Found Then
+          ReDim Preserve Categories(CatCount)
+          Categories(CatCount) = Trim(objItem.Categories)
+          CatCount = CatCount + 1
+        End If
+      End If
+    End If
+  Next
+  KategorieSelector.StatusLabel.Caption = CStr(SearchedCount) + " Einträge 
durchsucht."
+  KategorieSelector.KategoriesListBox.List = Categories
+  KategorieSelector.Show
+  
+  If KategorieSelector.KategoriesListBox.ListIndex = -1 Then
+    GetSelectedCategory2000 = ""
+    MsgBox "Keine Kategorien gewählt, es werden deshalb alle exportiert."
+    Exit Function
+  End If
+  GetSelectedCategory2000 = 
KategorieSelector.KategoriesListBox.List(KategorieSelector.KategoriesListBox.ListIndex)
+End Function
+
+Private Function CheckFor2003(Outlook As Application)
+    Dim FirstDotPos As Integer
+    Dim MajorVersion As String
+    
+    FirstDotPos = InStr(1, Outlook.Version, ".", vbTextCompare)
+    MajorVersion = Int(Left(Outlook.Version, FirstDotPos - 1))
+    If MajorVersion < 11 Then
+      CheckFor2003 = False
+    Else
+      CheckFor2003 = True
+    End If
+End Function
+
+Private Function AddKundenNr(inFileName As String, vcardFileName As String, 
KdNr As Integer) As Integer
+    Dim sLine As String
+    Dim outFN, inFN As Integer
+    
+    outFN = FreeFile()
+    inFN = outFN + 1
+    
+    'open the text files
+    Open vcardFileName For Output As #outFN
+    Open inFileName For Input As #inFN
+
+    'until the end of file
+    While Not EOF(inFN)
+
+        'read the line and store it in a variable
+        Line Input #inFN, sLine
+
+        If (InStr(1, sLine, "END:VCARD", vbTextCompare) > 0) Then
+          sLine = "X-KdNr:" + CStr(KdNr) + vbCrLf + sLine
+        End If
+        
+        'write to output
+        Print #outFN, sLine
+
+    'loop
+    Wend
+
+    'close the file
+    Close #inFN
+    Close #outFN
+    AddKundenNr = 1
+
+End Function
+
+Public Function KillFileProperly(Killfile As String)
+    If Len(Dir$(Killfile)) > 0 Then
+        SetAttr Killfile, vbNormal
+        Kill Killfile
+    End If
+End Function
+
 Sub KontaktIDExport()
   Dim objApp As Application
   Dim objNS As NameSpace
   Dim objContacts As MAPIFolder
   Dim colItems As Items
   Dim objItem As Object
+  Dim objProperty As Outlook.UserProperty
   Dim strAddress As String
   Dim guidstr As String
   Dim blnFound As Boolean
   Dim PathExists As Boolean
   Dim ItemWithCount As Integer
   Dim ItemWithoutCount As Integer
+  Dim CustomerID As Integer
+  Dim KdNrResult As Integer
   Dim catdir As String
   Dim destdir As String
   Dim selectedcategory As String
@@ -171,22 +281,28 @@
   ' get folder to search (Select Folder Dialog)
   Set objContacts = objNS.PickFolder
   
-  If Not (objContacts Is Nothing) Then
+  If objContacts Is Nothing Then
+    MsgBox "kein Ordner ausgewählt! - Abbruch"
+    Exit Sub
+  End If
   
   destdir = BrowseForFolder("Bitte Zielverzeichnis auswählen", defaultdestdir)
-  If (destdir <> "") Then
+  If (destdir = "") Then
+    MsgBox "kein Verzeichnis gewählt! - Abbruch"
+    Exit Sub
+  End If
   
   PathExists = (Len(VBA.Dir(PathName:=destdir, Attributes:=vbDirectory)) <> 0)
   If Not PathExists Then
     MsgBox "Der Zielordner existiert nicht - bitte passen sie das Macro 
entsprechend an!"
-  Else
+    Exit Sub
+  End If
 
-  ' 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
+  If CheckFor2003(objApp) Then
+    selectedcategory = GetSelectedCategory
+  Else
+    selectedcategory = GetSelectedCategory2000(objContacts)
+  End If
   
   objContacts.Items.ResetColumns
   
@@ -197,6 +313,7 @@
   ItemWithCount = 0
   ItemWithoutCount = 0
   
+  On Error GoTo ErrorHandler
     For Each objItem In colItems
       If TypeName(objItem) = "ContactItem" Then
         If (objItem.GovernmentIDNumber <> "") Then
@@ -214,12 +331,29 @@
 '        Else
           catdir = destdir
 '        End If
+          
+        If (objItem.CustomerID <> "") Then
+            CustomerID = objItem.CustomerID
+        Else
+            CustomerID = 0
+        End If
+
         If (selectedcategory <> "") Then
           If (InStr(1, objItem.Categories, selectedcategory, vbTextCompare) > 
0) Then
-            objItem.SaveAs catdir & "\" & objItem.GovernmentIDNumber & ".vcd", 
olVCard
+            If (CustomerID <> 0) Then
+              objItem.SaveAs catdir & "\" & "temp.vcd", olVCard
+              KdNrResult = AddKundenNr(catdir & "\" & "temp.vcd", catdir & "\" 
& objItem.GovernmentIDNumber & ".vcd", CustomerID)
+            Else
+              objItem.SaveAs catdir & "\" & objItem.GovernmentIDNumber & 
".vcd", olVCard
+            End If
           End If
         Else
-          objItem.SaveAs catdir & "\" & objItem.GovernmentIDNumber & ".vcd", 
olVCard
+            If (CustomerID <> 0) Then
+              objItem.SaveAs catdir & "\" & "temp.vcd", olVCard
+              KdNrResult = AddKundenNr(catdir & "\" & "temp.vcd", catdir & "\" 
& objItem.GovernmentIDNumber & ".vcd", CustomerID)
+            Else
+              objItem.SaveAs catdir & "\" & objItem.GovernmentIDNumber & 
".vcd", olVCard
+            End If
         End If
       End If
     Next
@@ -227,19 +361,24 @@
   MsgBox (CStr(ItemWithCount) + " Einträge mit ID gefunden, " + _
      CStr(ItemWithoutCount) + " Einträge ohne ID gefunden und mit ID versehen. 
Daten wurden exportiert.")
   
-  End If ' destpath
-  
-  Else
-    MsgBox "kein Verzeichnis gewählt! - Abbruch"
-  End If
-
-  Else
-    MsgBox "kein Ordner ausgewählt! - Abbruch"
-  End If
+ExitPoint:
+  On Error GoTo 0
+  KillFileProperly (catdir & "\" & "temp.vcd")
   
   Set objItem = Nothing
   Set colItems = Nothing
   Set objContacts = Nothing
   Set objNS = Nothing
   Set objApp = Nothing
+  Exit Sub
+ErrorHandler:
+    Select Case Err.Number    ' Fehlernummer auswerten.
+        Case 287
+          MsgBox "Zugriff auf die Kontakteinträge wurde nicht erlaubt. 
Abbruch."
+          Exit Sub
+        Case Else
+            ' Andere Fälle hier bearbeiten...
+    End Select
+      'Resume    ' Ausführung in der Zeile
+                ' fortsetzen, die den Fehler auftrat
 End Sub