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