[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Phpgroupware-cvs] sync/tools/idgenexport.bas, 1.4
From: |
nomail |
Subject: |
[Phpgroupware-cvs] sync/tools/idgenexport.bas, 1.4 |
Date: |
Wed, 14 Jul 2004 19:07:20 +0200 |
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
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Phpgroupware-cvs] sync/tools/idgenexport.bas, 1.4,
nomail <=