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

[nomail]

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

date: 2004/07/14 17:07:20;  author: mleonhardt;  state: Exp;  lines: +214 -214

Log Message:
binary -> ascii
=====================================================================
Index: sync/tools/idgenexport.bas
diff -u sync/tools/idgenexport.bas:1.3 sync/tools/idgenexport.bas:1.4
--- sync/tools/idgenexport.bas:1.3      Wed Jul 14 17:05:38 2004
+++ sync/tools/idgenexport.bas  Wed Jul 14 17:07:20 2004
@@ -1,214 +1,214 @@
-' $Id$
-Attribute VB_Name = "idgenexport"
-Option Explicit
-
-Public m_CurrentDirectory As String 'The current directory
-
-Private Const BIF_STATUSTEXT = &H4&
-Private Const BIF_RETURNONLYFSDIRS = 1
-Private Const BIF_DONTGOBELOWDOMAIN = 2
-Private Const MAX_PATH = 260
-
-Private Const WM_USER = &H400
-Private Const BFFM_INITIALIZED = 1
-Private Const BFFM_SELCHANGED = 2
-Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
-Private Const BFFM_SETSELECTION = (WM_USER + 102)
-
-'Declare Win32 API.
-Private Declare Function CoCreateGuid Lib "OLE32.DLL" (pGuid As guid) As Long
-Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal 
hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) 
As Long
-Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) 
As Long
-Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As 
Long, ByVal lpBuffer As String) As Long
-Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal 
lpString1 As String, ByVal lpString2 As String) As Long
-
-'Declare some types for API functions
-Private Type BrowseInfo
-    hWndOwner As Long
-    pIDLRoot As Long
-    pszDisplayName As Long
-    lpszTitle As Long
-    ulFlags As Long
-    lpfnCallback As Long
-    lParam As Long
-    iImage As Long
-End Type
-
-'Define the guid data type.
-Private Type guid
-    Data1 As Long
-    Data2 As Integer
-    Data3 As Integer
-    Data4(7) As Byte
-End Type
-
-'GUID to string converter function
-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
-
-'Folderbrowser
-Public Function BrowseForFolder(Title As String, StartDir As String) As String
-
-Dim lpIDList As Long
-Dim szTitle As String
-Dim sBuffer As String
-Dim tBrowseInfo As BrowseInfo
-
-m_CurrentDirectory = StartDir & vbNullChar
-
-szTitle = Title
-With tBrowseInfo
-'    .hWndOwner = owner.hWnd
-    .lpszTitle = lstrcat(szTitle, "")
-    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT
-    .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc) 'get 
address of function.
-End With
-
-lpIDList = SHBrowseForFolder(tBrowseInfo)
-If (lpIDList) Then
-    sBuffer = Space(MAX_PATH)
-    SHGetPathFromIDList lpIDList, sBuffer
-    sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
-    BrowseForFolder = sBuffer
-Else
-    BrowseForFolder = ""
-End If
-
-End Function
-
-'callback to set the start directory
-Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, 
ByVal lp As Long, ByVal pData As Long) As Long
-
-Dim lpIDList As Long
-Dim ret As Long
-Dim sBuffer As String
-
-On Error Resume Next 'Sugested by MS to prevent an error from
-'propagating back into the calling process.
-
-Select Case uMsg
-
-    Case BFFM_INITIALIZED
-        Call SendMessage(hWnd, BFFM_SETSELECTION, 1, m_CurrentDirectory)
-    Case BFFM_SELCHANGED
-        sBuffer = Space(MAX_PATH)
-        ret = SHGetPathFromIDList(lp, sBuffer)
-        If ret = 1 Then
-            Call SendMessage(hWnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
-        End If
-End Select
-
-BrowseCallbackProc = 0
-
-End Function
-
-' This function allows you to assign a function pointer to a vaiable.
-Private Function GetAddressofFunction(add As Long) As Long
-    GetAddressofFunction = add
-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
-  Dim catdir As String
-  Dim destdir As String
-  
-  Const defaultdestdir = "c:\"
-  
-  ' connect to Outlook
-  Set objApp = CreateObject("Outlook.Application")
-  Set objNS = objApp.GetNamespace("MAPI")
-  
-  ' 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
-  
-  If Not (objContacts Is Nothing) Then
-  
-  destdir = BrowseForFolder("Bitte Zielverzeichnis auswählen", defaultdestdir)
-  If (destdir <> "") Then
-  
-  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
-
-  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
-            ' generate a new GUID by calling Windows OLE32.dll
-            guidstr = GetGUID()
-            objItem.GovernmentIDNumber = guidstr
-            objItem.Save
-        End If
-'        If (objItem.Categories <> "") Then
-'          catdir = destdir + "\" + objItem.Categories
-'        Else
-          catdir = destdir
-'        End If
-        objItem.SaveAs catdir & "\" & 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. 
Daten wurden exportiert.")
-  
-  End If ' destpath
-  
-  Else
-    MsgBox "kein Verzeichnis gewählt! - Abbruch"
-  End If
-
-  Else
-    MsgBox "kein Ordner ausgewählt! - Abbruch"
-  End If
-  
-  Set objItem = Nothing
-  Set colItems = Nothing
-  Set objContacts = Nothing
-  Set objNS = Nothing
-  Set objApp = Nothing
-End Sub
+' $Id$
+Attribute VB_Name = "idgenexport"
+Option Explicit
+
+Public m_CurrentDirectory As String 'The current directory
+
+Private Const BIF_STATUSTEXT = &H4&
+Private Const BIF_RETURNONLYFSDIRS = 1
+Private Const BIF_DONTGOBELOWDOMAIN = 2
+Private Const MAX_PATH = 260
+
+Private Const WM_USER = &H400
+Private Const BFFM_INITIALIZED = 1
+Private Const BFFM_SELCHANGED = 2
+Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
+Private Const BFFM_SETSELECTION = (WM_USER + 102)
+
+'Declare Win32 API.
+Private Declare Function CoCreateGuid Lib "OLE32.DLL" (pGuid As guid) As Long
+Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal 
hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) 
As Long
+Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) 
As Long
+Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As 
Long, ByVal lpBuffer As String) As Long
+Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal 
lpString1 As String, ByVal lpString2 As String) As Long
+
+'Declare some types for API functions
+Private Type BrowseInfo
+    hWndOwner As Long
+    pIDLRoot As Long
+    pszDisplayName As Long
+    lpszTitle As Long
+    ulFlags As Long
+    lpfnCallback As Long
+    lParam As Long
+    iImage As Long
+End Type
+
+'Define the guid data type.
+Private Type guid
+    Data1 As Long
+    Data2 As Integer
+    Data3 As Integer
+    Data4(7) As Byte
+End Type
+
+'GUID to string converter function
+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
+
+'Folderbrowser
+Public Function BrowseForFolder(Title As String, StartDir As String) As String
+
+Dim lpIDList As Long
+Dim szTitle As String
+Dim sBuffer As String
+Dim tBrowseInfo As BrowseInfo
+
+m_CurrentDirectory = StartDir & vbNullChar
+
+szTitle = Title
+With tBrowseInfo
+'    .hWndOwner = owner.hWnd
+    .lpszTitle = lstrcat(szTitle, "")
+    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT
+    .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc) 'get 
address of function.
+End With
+
+lpIDList = SHBrowseForFolder(tBrowseInfo)
+If (lpIDList) Then
+    sBuffer = Space(MAX_PATH)
+    SHGetPathFromIDList lpIDList, sBuffer
+    sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
+    BrowseForFolder = sBuffer
+Else
+    BrowseForFolder = ""
+End If
+
+End Function
+
+'callback to set the start directory
+Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, 
ByVal lp As Long, ByVal pData As Long) As Long
+
+Dim lpIDList As Long
+Dim ret As Long
+Dim sBuffer As String
+
+On Error Resume Next 'Sugested by MS to prevent an error from
+'propagating back into the calling process.
+
+Select Case uMsg
+
+    Case BFFM_INITIALIZED
+        Call SendMessage(hWnd, BFFM_SETSELECTION, 1, m_CurrentDirectory)
+    Case BFFM_SELCHANGED
+        sBuffer = Space(MAX_PATH)
+        ret = SHGetPathFromIDList(lp, sBuffer)
+        If ret = 1 Then
+            Call SendMessage(hWnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
+        End If
+End Select
+
+BrowseCallbackProc = 0
+
+End Function
+
+' This function allows you to assign a function pointer to a vaiable.
+Private Function GetAddressofFunction(add As Long) As Long
+    GetAddressofFunction = add
+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
+  Dim catdir As String
+  Dim destdir As String
+  
+  Const defaultdestdir = "c:\"
+  
+  ' connect to Outlook
+  Set objApp = CreateObject("Outlook.Application")
+  Set objNS = objApp.GetNamespace("MAPI")
+  
+  ' 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
+  
+  If Not (objContacts Is Nothing) Then
+  
+  destdir = BrowseForFolder("Bitte Zielverzeichnis auswählen", defaultdestdir)
+  If (destdir <> "") Then
+  
+  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
+
+  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
+            ' generate a new GUID by calling Windows OLE32.dll
+            guidstr = GetGUID()
+            objItem.GovernmentIDNumber = guidstr
+            objItem.Save
+        End If
+'        If (objItem.Categories <> "") Then
+'          catdir = destdir + "\" + objItem.Categories
+'        Else
+          catdir = destdir
+'        End If
+        objItem.SaveAs catdir & "\" & 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. 
Daten wurden exportiert.")
+  
+  End If ' destpath
+  
+  Else
+    MsgBox "kein Verzeichnis gewählt! - Abbruch"
+  End If
+
+  Else
+    MsgBox "kein Ordner ausgewählt! - Abbruch"
+  End If
+  
+  Set objItem = Nothing
+  Set colItems = Nothing
+  Set objContacts = Nothing
+  Set objNS = Nothing
+  Set objApp = Nothing
+End Sub