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	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	'MsgBox Get_User_Name()
9
10	joko	1.2	' 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	joko	1.4
42			' debugging
43	joko	1.5	' MsgBox _
44			' "Windows user name: " & Get_User_Name() & vbCrLf & _
45			' "Outlook user name: " & mailer.Session.CurrentUser()
46	joko	1.4
47	joko	1.2	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	joko	1.4	"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	joko	1.3	"HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Print\Monitors\Winprint Hylafax\Ports\" & hfax_port & "\MapiFolderPath", _
60	joko	1.4	vbCritical + vbOKOnly, "Error"
61	joko	1.2	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	joko	1.4	MsgBox "Addressbook refresh failed.", vbExclamation + vbOKOnly, "Error"
80	joko	1.2	End If
81
82	joko	1.1	End Sub
83	joko	1.2
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	joko	1.4
97			' get named folder
98	joko	1.2	On Error Resume Next
99	joko	1.4	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	joko	1.2	On Error GoTo 0
105	joko	1.4
106	joko	1.2	'MsgBox "name: " & entry.Name
107	joko	1.4
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	joko	1.2	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	joko	1.3	getRegistrySetting = regQuery_A_Key(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Print\Monitors\Winprint Hylafax\Ports\" & portName, subKey)
170	joko	1.2	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