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	Attribute VB_Name = "ModuleMain"
2	' (c) Andreas Motl <andreas.motl@ilo.de>, 2007-09-01
3
4	Option Explicit
5
6	Public Sub Main()
7
8	' testing
9	'MsgBox Get_User_Name()
10
11	' 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
43	' debugging
44	'MsgBox mailer.Session.CurrentUser()
45
46	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	"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	"HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Print\Monitors\Winprint Hylafax\Ports\" & hfax_port & "\MapiFolderPath", _
59	vbCritical + vbOKOnly, "Error"
60	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	MsgBox "Addressbook refresh failed.", vbExclamation + vbOKOnly, "Error"
79	End If
80
81	End Sub
82
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
96	' get named folder
97	On Error Resume Next
98	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	On Error GoTo 0
104
105	'MsgBox "name: " & entry.Name
106
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	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	getRegistrySetting = regQuery_A_Key(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Print\Monitors\Winprint Hylafax\Ports\" & portName, subKey)
169	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