/[cvs]/joko/ToolBox/Windows/HylaPrintMon_MapiContactsDumper/ModuleMain.bas
ViewVC logotype

Diff of /joko/ToolBox/Windows/HylaPrintMon_MapiContactsDumper/ModuleMain.bas

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by joko, Sat Sep 1 12:40:38 2007 UTC revision 1.4 by joko, Mon Sep 3 18:35:03 2007 UTC
# Line 1  Line 1 
1  Attribute VB_Name = "ModuleMain"  Attribute VB_Name = "ModuleMain"
2  Sub Main()  ' (c) Andreas Motl <andreas.motl@ilo.de>, 2007-09-01
3      MsgBox ("hello world!")  
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  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
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.4
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed