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 |