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 |