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

[nomail]

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

date: 2004/07/14 17:05:38;  author: mleonhardt;  state: Exp;  lines: +123 -16

Log Message:
- target dir can now be selected in a Directory Select Dialog
=====================================================================
Index: sync/tools/idgenexport.bas
diff -u sync/tools/idgenexport.bas:1.2 sync/tools/idgenexport.bas:1.3
--- sync/tools/idgenexport.bas:1.2      Mon Jul 12 20:08:02 2004
+++ sync/tools/idgenexport.bas  Wed Jul 14 17:05:38 2004
@@ -1,5 +1,40 @@
 ' $Id$
-' Define the guid data type.
+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
@@ -7,10 +42,7 @@
     Data4(7) As Byte
 End Type
 
-'Declare Win32 API.
-Private Declare Function CoCreateGuid Lib "OLE32.DLL" (pGuid As guid) As Long
-
-
+'GUID to string converter function
 Public Function GetGUID() As String
 
     Dim udtGUID As guid
@@ -32,6 +64,67 @@
 
 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
@@ -44,18 +137,15 @@
   Dim PathExists As Boolean
   Dim ItemWithCount As Integer
   Dim ItemWithoutCount As Integer
+  Dim catdir As String
+  Dim destdir As String
   
-  destdir = "F:\temp\7"
+  Const defaultdestdir = "c:\"
   
   ' connect to Outlook
   Set objApp = CreateObject("Outlook.Application")
   Set objNS = objApp.GetNamespace("MAPI")
   
-  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"
@@ -65,6 +155,14 @@
   
   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
@@ -86,19 +184,28 @@
             objItem.GovernmentIDNumber = guidstr
             objItem.Save
         End If
-        objItem.SaveAs destdir & "\" & objItem.GovernmentIDNumber & ".vcd", 
olVCard
+'        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 Ordner ausgewählt - Abbruch"
+    MsgBox "kein Verzeichnis gewählt! - Abbruch"
   End If
-  
-  End If ' destpath
 
+  Else
+    MsgBox "kein Ordner ausgewählt! - Abbruch"
+  End If
+  
   Set objItem = Nothing
   Set colItems = Nothing
   Set objContacts = Nothing