Windows/HylaPrintMon_MapiContactsDumper/ModuleMain.bas

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

Option Explicit

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