Windows/HylaPrintMon_MapiContactsDumper/ModuleMain.bas

Attribute VB_Name = "ModuleMain"
' (c) Andreas Motl <andreas.motl@ilo.de>, 2007-09-01

Option Explicit

Public Sub Main()
    
    ' testing
    'MsgBox Get_User_Name()
    
    ' get port name from command line
    Dim hfax_port As String
    'hfax_port = "HFAX1:"
    hfax_port = getCmdArg("--port")
    
    ' sanity checks
    If hfax_port = "" Then
        MsgBox "Command line argument '--port' is missing.", vbOKOnly, "ERROR"
        End
    End If
    
    ' read essential information from registry settings of Winprint HylaFAX Port
    Dim MapiFolderPath As String, AddressBookPath As String, AddressBookType As String
    MapiFolderPath = getRegistrySetting(hfax_port, "MapiFolderPath")
    AddressBookPath = getRegistrySetting(hfax_port, "AddressBookPath")
    AddressBookType = getRegistrySetting(hfax_port, "AddressBookType")
    
    ' sanity checks
    If Not DirectoryExists(AddressBookPath) Then
        MsgBox "AddressBookPath '" & AddressBookPath & "' does not exist.", vbCritical + vbOKOnly, "ERROR"
        End
    End If
    
    If AddressBookType = "" Then
        MsgBox "AddressBookType is empty.", vbCritical + vbOKOnly, "ERROR"
        End
    End If
    
    
    ' open MAPI folder
    mailerStart
    
    ' debugging
    'MsgBox mailer.Session.CurrentUser()
    
    Dim contactsFolder As Outlook.MAPIFolder
    
    If MapiFolderPath = "" Then
        Set contactsFolder = mailer.Session.GetDefaultFolder(olFolderContacts)
    Else
        'Set contactsFolder = getFolderByPath(mailer.Session.Folders, "/Öffentliche Ordner/Alle Öffentlichen Ordner/EDV/plugin_test", 0)
        Set contactsFolder = getFolderByPath(mailer.Session.Folders, MapiFolderPath, 0)
        If contactsFolder Is Nothing Then
            MsgBox _
                "Problem while opening MAPI folder '" & MapiFolderPath & "'." & vbCrLf & _
                "Maybe the server is not available?" & vbCrLf & vbCrLf & _
                "Otherwise please check in port settings dialog or registry:" & vbCrLf & _
                "HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Print\Monitors\Winprint Hylafax\Ports\" & hfax_port & "\MapiFolderPath", _
                vbCritical + vbOKOnly, "Error"
            End
        End If
    End If
    
    ' read contacts from MAPI folder into array of dictionaries
    Dim entries As Variant, entry As Variant
    entries = readMapiFolderToArray(contactsFolder)
    
'    ' debugging: output results to gui
'    For Each entry In entries
'        MsgBox entry("label") & ": " & entry("faxnumber"), vbOKOnly, "Fax-Contact"
'    Next
    
    ' write results to addressbook files
    Dim count As Integer
    If writeAddressbook(entries, AddressBookType, AddressBookPath, count) = True Then
        MsgBox "Addressbook refreshed successfully (" & count & " entries).", vbInformation + vbOKOnly, "OK"
    Else
        MsgBox "Addressbook refresh failed.", vbExclamation + vbOKOnly, "Error"
    End If
    
End Sub

Private Function getFolderByPath(ByVal rootFolders As Outlook.Folders, folderPath As String, partsIndex As Integer) As Outlook.MAPIFolder
    
    ' split path into parts
    Dim parts As Variant, part As Variant
    parts = Split(folderPath, "/")
    
    partsIndex = partsIndex + 1
    Dim entry As Outlook.MAPIFolder

    For Each part In parts
        If part <> "" Then
            'MsgBox "part: " & part
            
            ' get named folder
            On Error Resume Next
                Set entry = rootFolders.Item(part)
                If Err.Number <> 0 Then
                    MsgBox Err.Description & vbCrLf & vbCrLf & "Problem while using folder '" & part & "', " & vbCrLf & "complete path was '" & folderPath & "'.", vbExclamation + vbOKOnly, "Error"
                    Exit Function
                End If
            On Error GoTo 0
            
            'MsgBox "name: " & entry.Name
            
            ' get subfolders
            On Error Resume Next
                Set rootFolders = entry.Folders
                If Err.Number <> 0 Then
                    MsgBox Err.Description & vbCrLf & vbCrLf & "Problem while using subfolders of '" & part & "', " & vbCrLf & "complete path was '" & folderPath & "'.", vbExclamation + vbOKOnly, "Error"
                    Exit Function
                End If
            On Error GoTo 0
            
        End If
    Next

    Set getFolderByPath = entry
    
End Function

Private Function readMapiFolderToBuffer(myFolder As Outlook.MAPIFolder) As Variant
    Dim contactItem As Outlook.contactItem
    Dim objAttribute As Variant
    'myfolder.Items.Item(
    Dim buffer As String
    For Each contactItem In myFolder.Items
        'MsgBox contactItem.NickName
        'contactItem.us
        'MsgBox contactItem.l
        'Text1.Text = Text1.Text & contactItem.LastName & vbCrLf
        buffer = buffer & _
            "firstname: " & contactItem.FirstName & vbCrLf & _
            "lastname: " & contactItem.LastName & vbCrLf & _
            "business fax: " & contactItem.BusinessFaxNumber & vbCrLf & _
            "email: " & contactItem.Email1DisplayName & " <" & contactItem.Email1Address & ">" & vbCrLf
    Next
    readMapiFolderToBuffer = buffer
End Function

Private Function readMapiFolderToArray(myFolder As Outlook.MAPIFolder) As Variant
    
    Dim buffer() As Dictionary
    Dim x As Integer
    
    Dim contactItem As Outlook.contactItem
    For Each contactItem In myFolder.Items
        
        ' just use contacts with fax number
        If contactItem.BusinessFaxNumber <> "" Then
            
            ' create new dictionary and append to dynamic array
            ReDim Preserve buffer(x)
            Set buffer(x) = New Dictionary
            buffer(x)("label") = contactItem.LastName & " " & contactItem.FirstName
            buffer(x)("faxnumber") = contactItem.BusinessFaxNumber
            x = x + 1
            
        End If
        
    Next
    readMapiFolderToArray = buffer
    
End Function

Private Function getRegistrySetting(portName As String, subKey As String) As String
    getRegistrySetting = regQuery_A_Key(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Print\Monitors\Winprint Hylafax\Ports\" & portName, subKey)
End Function

Private Function writeAddressbook(ByRef entries As Variant, abFormat As String, abPath As String, ByRef count As Integer) As Boolean
    
    writeAddressbook = False
    
    If abFormat = "Two Text Files" Then
    
        If MsgBox("names.txt and numbers.txt in '" & abPath & "' will be overwritten. Continue?", vbQuestion + vbYesNo, "Overwrite files?") = vbYes Then
    
            Dim fh_names As Integer, fh_numbers As Integer
            
            fh_names = FreeFile
            Open abPath & "\" & "names.txt" For Output As #fh_names
            
            fh_numbers = FreeFile
            Open abPath & "\" & "numbers.txt" For Output As #fh_numbers
            
            Dim entry As Variant
            For Each entry In entries
                'MsgBox entry("label") & ": " & entry("faxnumber"), vbOKOnly, "Fax-Contact"
                Print #fh_names, entry("label")
                Print #fh_numbers, entry("faxnumber")
                count = count + 1
            Next
            
            Close #fh_names
            Close #fh_numbers
            
            writeAddressbook = True
        
        End If
        
    ElseIf abFormat = "CSV" Then
        MsgBox "Addressbook format 'CSV' not supported yet.", vbExclamation + vbOKOnly, "ERROR"
    
    Else
        MsgBox "Unknown addressbook format '" & abFormat & "'.", vbExclamation + vbOKOnly, "ERROR"
    End If
    
End Function
1	joko	1.1	Attribute VB_Name = "ModuleMain"
2	joko	1.2	' (c) Andreas Motl <andreas.motl@ilo.de>, 2007-09-01
3
4			Option Explicit
5
6			Public Sub Main()
7
8	joko	1.4	' testing
9			'MsgBox Get_User_Name()
10
11	joko	1.2	' get port name from command line
12			Dim hfax_port As String
13			'hfax_port = "HFAX1:"
14			hfax_port = getCmdArg("--port")
15
16			' sanity checks
17			If hfax_port = "" Then
18			MsgBox "Command line argument '--port' is missing.", vbOKOnly, "ERROR"
19			End
20			End If
21
22			' read essential information from registry settings of Winprint HylaFAX Port
23			Dim MapiFolderPath As String, AddressBookPath As String, AddressBookType As String
24			MapiFolderPath = getRegistrySetting(hfax_port, "MapiFolderPath")
25			AddressBookPath = getRegistrySetting(hfax_port, "AddressBookPath")
26			AddressBookType = getRegistrySetting(hfax_port, "AddressBookType")
27
28			' sanity checks
29			If Not DirectoryExists(AddressBookPath) Then
30			MsgBox "AddressBookPath '" & AddressBookPath & "' does not exist.", vbCritical + vbOKOnly, "ERROR"
31			End
32			End If
33
34			If AddressBookType = "" Then
35			MsgBox "AddressBookType is empty.", vbCritical + vbOKOnly, "ERROR"
36			End
37			End If
38
39
40			' open MAPI folder
41			mailerStart
42	joko	1.4
43			' debugging
44			'MsgBox mailer.Session.CurrentUser()
45
46	joko	1.2	Dim contactsFolder As Outlook.MAPIFolder
47
48			If MapiFolderPath = "" Then
49			Set contactsFolder = mailer.Session.GetDefaultFolder(olFolderContacts)
50			Else
51			'Set contactsFolder = getFolderByPath(mailer.Session.Folders, "/Öffentliche Ordner/Alle Öffentlichen Ordner/EDV/plugin_test", 0)
52			Set contactsFolder = getFolderByPath(mailer.Session.Folders, MapiFolderPath, 0)
53			If contactsFolder Is Nothing Then
54			MsgBox _
55	joko	1.4	"Problem while opening MAPI folder '" & MapiFolderPath & "'." & vbCrLf & _
56			"Maybe the server is not available?" & vbCrLf & vbCrLf & _
57			"Otherwise please check in port settings dialog or registry:" & vbCrLf & _
58	joko	1.3	"HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Print\Monitors\Winprint Hylafax\Ports\" & hfax_port & "\MapiFolderPath", _
59	joko	1.4	vbCritical + vbOKOnly, "Error"
60	joko	1.2	End
61			End If
62			End If
63
64			' read contacts from MAPI folder into array of dictionaries
65			Dim entries As Variant, entry As Variant
66			entries = readMapiFolderToArray(contactsFolder)
67
68			' ' debugging: output results to gui
69			' For Each entry In entries
70			' MsgBox entry("label") & ": " & entry("faxnumber"), vbOKOnly, "Fax-Contact"
71			' Next
72
73			' write results to addressbook files
74			Dim count As Integer
75			If writeAddressbook(entries, AddressBookType, AddressBookPath, count) = True Then
76			MsgBox "Addressbook refreshed successfully (" & count & " entries).", vbInformation + vbOKOnly, "OK"
77			Else
78	joko	1.4	MsgBox "Addressbook refresh failed.", vbExclamation + vbOKOnly, "Error"
79	joko	1.2	End If
80
81	joko	1.1	End Sub
82	joko	1.2
83			Private Function getFolderByPath(ByVal rootFolders As Outlook.Folders, folderPath As String, partsIndex As Integer) As Outlook.MAPIFolder
84
85			' split path into parts
86			Dim parts As Variant, part As Variant
87			parts = Split(folderPath, "/")
88
89			partsIndex = partsIndex + 1
90			Dim entry As Outlook.MAPIFolder
91
92			For Each part In parts
93			If part <> "" Then
94			'MsgBox "part: " & part
95	joko	1.4
96			' get named folder
97	joko	1.2	On Error Resume Next
98	joko	1.4	Set entry = rootFolders.Item(part)
99			If Err.Number <> 0 Then
100			MsgBox Err.Description & vbCrLf & vbCrLf & "Problem while using folder '" & part & "', " & vbCrLf & "complete path was '" & folderPath & "'.", vbExclamation + vbOKOnly, "Error"
101			Exit Function
102			End If
103	joko	1.2	On Error GoTo 0
104	joko	1.4
105	joko	1.2	'MsgBox "name: " & entry.Name
106	joko	1.4
107			' get subfolders
108			On Error Resume Next
109			Set rootFolders = entry.Folders
110			If Err.Number <> 0 Then
111			MsgBox Err.Description & vbCrLf & vbCrLf & "Problem while using subfolders of '" & part & "', " & vbCrLf & "complete path was '" & folderPath & "'.", vbExclamation + vbOKOnly, "Error"
112			Exit Function
113			End If
114			On Error GoTo 0
115
116	joko	1.2	End If
117			Next
118
119			Set getFolderByPath = entry
120
121			End Function
122
123			Private Function readMapiFolderToBuffer(myFolder As Outlook.MAPIFolder) As Variant
124			Dim contactItem As Outlook.contactItem
125			Dim objAttribute As Variant
126			'myfolder.Items.Item(
127			Dim buffer As String
128			For Each contactItem In myFolder.Items
129			'MsgBox contactItem.NickName
130			'contactItem.us
131			'MsgBox contactItem.l
132			'Text1.Text = Text1.Text & contactItem.LastName & vbCrLf
133			buffer = buffer & _
134			"firstname: " & contactItem.FirstName & vbCrLf & _
135			"lastname: " & contactItem.LastName & vbCrLf & _
136			"business fax: " & contactItem.BusinessFaxNumber & vbCrLf & _
137			"email: " & contactItem.Email1DisplayName & " <" & contactItem.Email1Address & ">" & vbCrLf
138			Next
139			readMapiFolderToBuffer = buffer
140			End Function
141
142			Private Function readMapiFolderToArray(myFolder As Outlook.MAPIFolder) As Variant
143
144			Dim buffer() As Dictionary
145			Dim x As Integer
146
147			Dim contactItem As Outlook.contactItem
148			For Each contactItem In myFolder.Items
149
150			' just use contacts with fax number
151			If contactItem.BusinessFaxNumber <> "" Then
152
153			' create new dictionary and append to dynamic array
154			ReDim Preserve buffer(x)
155			Set buffer(x) = New Dictionary
156			buffer(x)("label") = contactItem.LastName & " " & contactItem.FirstName
157			buffer(x)("faxnumber") = contactItem.BusinessFaxNumber
158			x = x + 1
159
160			End If
161
162			Next
163			readMapiFolderToArray = buffer
164
165			End Function
166
167			Private Function getRegistrySetting(portName As String, subKey As String) As String
168	joko	1.3	getRegistrySetting = regQuery_A_Key(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Print\Monitors\Winprint Hylafax\Ports\" & portName, subKey)
169	joko	1.2	End Function
170
171			Private Function writeAddressbook(ByRef entries As Variant, abFormat As String, abPath As String, ByRef count As Integer) As Boolean
172
173			writeAddressbook = False
174
175			If abFormat = "Two Text Files" Then
176
177			If MsgBox("names.txt and numbers.txt in '" & abPath & "' will be overwritten. Continue?", vbQuestion + vbYesNo, "Overwrite files?") = vbYes Then
178
179			Dim fh_names As Integer, fh_numbers As Integer
180
181			fh_names = FreeFile
182			Open abPath & "\" & "names.txt" For Output As #fh_names
183
184			fh_numbers = FreeFile
185			Open abPath & "\" & "numbers.txt" For Output As #fh_numbers
186
187			Dim entry As Variant
188			For Each entry In entries
189			'MsgBox entry("label") & ": " & entry("faxnumber"), vbOKOnly, "Fax-Contact"
190			Print #fh_names, entry("label")
191			Print #fh_numbers, entry("faxnumber")
192			count = count + 1
193			Next
194
195			Close #fh_names
196			Close #fh_numbers
197
198			writeAddressbook = True
199
200			End If
201
202			ElseIf abFormat = "CSV" Then
203			MsgBox "Addressbook format 'CSV' not supported yet.", vbExclamation + vbOKOnly, "ERROR"
204
205			Else
206			MsgBox "Unknown addressbook format '" & abFormat & "'.", vbExclamation + vbOKOnly, "ERROR"
207			End If
208
209			End Function
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26