Windows/HylaPrintMon_MapiContactsDumper/ModuleMain.bas

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

Option Explicit

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