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

[nomail]

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

date: 2004/07/12 20:08:02;  author: mleonhardt;  state: Exp;  lines: +55 -15

Log Message:
- update
=====================================================================
Index: sync/tools/idgenexport.bas
diff -u sync/tools/idgenexport.bas:1.1 sync/tools/idgenexport.bas:1.2
--- sync/tools/idgenexport.bas:1.1      Mon Jul 12 19:40:38 2004
+++ sync/tools/idgenexport.bas  Mon Jul 12 20:08:02 2004
@@ -1,25 +1,65 @@
 ' $Id$
-Sub SetUniqueIDsToFolder()
+' Define the guid data type.
+Private Type guid
+    Data1 As Long
+    Data2 As Integer
+    Data3 As Integer
+    Data4(7) As Byte
+End Type
+
+'Declare Win32 API.
+Private Declare Function CoCreateGuid Lib "OLE32.DLL" (pGuid As guid) As Long
+
+
+Public Function GetGUID() As String
+
+    Dim udtGUID As guid
+
+    If (CoCreateGuid(udtGUID) = 0) Then
+        GetGUID = _
+        String(8 - Len(Hex$(udtGUID.Data1)), "0") & Hex$(udtGUID.Data1) & _
+        String(4 - Len(Hex$(udtGUID.Data2)), "0") & Hex$(udtGUID.Data2) & _
+        String(4 - Len(Hex$(udtGUID.Data3)), "0") & Hex$(udtGUID.Data3) & _
+        IIf((udtGUID.Data4(0) < &H10), "0", "") & Hex$(udtGUID.Data4(0)) & _
+        IIf((udtGUID.Data4(1) < &H10), "0", "") & Hex$(udtGUID.Data4(1)) & _
+        IIf((udtGUID.Data4(2) < &H10), "0", "") & Hex$(udtGUID.Data4(2)) & _
+        IIf((udtGUID.Data4(3) < &H10), "0", "") & Hex$(udtGUID.Data4(3)) & _
+        IIf((udtGUID.Data4(4) < &H10), "0", "") & Hex$(udtGUID.Data4(4)) & _
+        IIf((udtGUID.Data4(5) < &H10), "0", "") & Hex$(udtGUID.Data4(5)) & _
+        IIf((udtGUID.Data4(6) < &H10), "0", "") & Hex$(udtGUID.Data4(6)) & _
+        IIf((udtGUID.Data4(7) < &H10), "0", "") & Hex$(udtGUID.Data4(7))
+    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 strAddress As String
+  Dim guidstr As String
   Dim blnFound As Boolean
+  Dim PathExists As Boolean
   Dim ItemWithCount As Integer
   Dim ItemWithoutCount As Integer
   
+  destdir = "F:\temp\7"
+  
   ' 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
-  
+  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
+
+  ' show infodialog
+  MsgBox "Bitte wählen Sie im nachfolgenden Dialog den gewünschen 
Outlookordner aus, " _
+    + "dessen Kontakte mit IDs versehen und exportiert werden sollen.", 
vbOKOnly, "pro|business Kontaktexport by Matthias Leonhardt"
+    
   ' get folder to search (Select Folder Dialog)
   Set objContacts = objNS.PickFolder
   
@@ -41,23 +81,23 @@
             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
+            ' generate a new GUID by calling Windows OLE32.dll
+            guidstr = GetGUID()
+            objItem.GovernmentIDNumber = guidstr
             objItem.Save
         End If
-        objItem.SaveAs "F:\temp\7\" & objItem.GovernmentIDNumber & ".vcd", 
olVCard
+        objItem.SaveAs destdir & "\" & 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.")
+     CStr(ItemWithoutCount) + " Einträge ohne ID gefunden und mit ID versehen. 
Daten wurden exportiert.")
   
   Else
-    MsgBox "kein Verzeichnis ausgewählt - Abbruch"
+    MsgBox "kein Ordner ausgewählt - Abbruch"
   End If
+  
+  End If ' destpath
 
   Set objItem = Nothing
   Set colItems = Nothing